123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904890589068907890889098910891189128913891489158916891789188919892089218922892389248925892689278928892989308931893289338934893589368937893889398940894189428943894489458946894789488949895089518952895389548955895689578958895989608961896289638964896589668967896889698970897189728973897489758976897789788979898089818982898389848985898689878988898989908991899289938994899589968997899889999000900190029003900490059006900790089009901090119012901390149015901690179018901990209021902290239024902590269027902890299030903190329033903490359036903790389039904090419042904390449045904690479048904990509051905290539054905590569057905890599060906190629063906490659066906790689069907090719072907390749075907690779078907990809081908290839084908590869087908890899090909190929093909490959096909790989099910091019102910391049105910691079108910991109111911291139114911591169117911891199120912191229123912491259126912791289129913091319132913391349135913691379138913991409141914291439144914591469147914891499150915191529153915491559156915791589159916091619162916391649165916691679168916991709171917291739174917591769177917891799180918191829183918491859186918791889189919091919192919391949195919691979198919992009201920292039204920592069207920892099210921192129213921492159216921792189219922092219222922392249225922692279228922992309231923292339234923592369237923892399240924192429243924492459246924792489249925092519252925392549255925692579258925992609261926292639264926592669267926892699270927192729273927492759276927792789279928092819282928392849285928692879288928992909291929292939294929592969297929892999300930193029303930493059306930793089309931093119312931393149315931693179318931993209321932293239324932593269327932893299330933193329333933493359336933793389339934093419342934393449345934693479348934993509351935293539354935593569357935893599360936193629363936493659366936793689369937093719372937393749375937693779378937993809381938293839384938593869387938893899390939193929393939493959396939793989399940094019402940394049405940694079408940994109411941294139414941594169417941894199420942194229423942494259426942794289429943094319432943394349435943694379438943994409441944294439444944594469447944894499450945194529453945494559456945794589459946094619462946394649465946694679468946994709471947294739474947594769477947894799480948194829483948494859486948794889489949094919492949394949495949694979498949995009501950295039504950595069507950895099510951195129513951495159516951795189519952095219522952395249525952695279528952995309531953295339534953595369537953895399540954195429543954495459546954795489549955095519552955395549555955695579558955995609561956295639564956595669567956895699570957195729573957495759576957795789579958095819582958395849585958695879588958995909591959295939594959595969597959895999600960196029603960496059606960796089609961096119612961396149615961696179618961996209621962296239624962596269627962896299630963196329633963496359636963796389639964096419642964396449645964696479648964996509651965296539654965596569657965896599660966196629663966496659666966796689669967096719672967396749675967696779678967996809681968296839684968596869687968896899690969196929693969496959696969796989699970097019702970397049705970697079708970997109711971297139714971597169717971897199720972197229723972497259726972797289729973097319732973397349735973697379738973997409741974297439744974597469747974897499750975197529753975497559756975797589759976097619762976397649765976697679768976997709771977297739774977597769777977897799780978197829783978497859786978797889789979097919792979397949795979697979798979998009801980298039804980598069807980898099810981198129813981498159816981798189819982098219822982398249825982698279828982998309831983298339834983598369837983898399840984198429843984498459846984798489849985098519852985398549855985698579858985998609861986298639864986598669867986898699870987198729873987498759876987798789879988098819882988398849885988698879888988998909891989298939894989598969897989898999900990199029903990499059906990799089909991099119912991399149915991699179918991999209921992299239924992599269927992899299930993199329933993499359936993799389939994099419942994399449945994699479948994999509951995299539954995599569957995899599960996199629963996499659966996799689969997099719972997399749975997699779978997999809981998299839984998599869987998899899990999199929993999499959996999799989999100001000110002100031000410005100061000710008100091001010011100121001310014100151001610017100181001910020100211002210023100241002510026100271002810029100301003110032100331003410035100361003710038100391004010041100421004310044100451004610047100481004910050100511005210053100541005510056100571005810059100601006110062100631006410065100661006710068100691007010071100721007310074100751007610077100781007910080100811008210083100841008510086100871008810089100901009110092100931009410095100961009710098100991010010101101021010310104101051010610107101081010910110101111011210113101141011510116101171011810119101201012110122101231012410125101261012710128101291013010131101321013310134101351013610137101381013910140101411014210143101441014510146101471014810149101501015110152101531015410155101561015710158101591016010161101621016310164101651016610167101681016910170101711017210173101741017510176101771017810179101801018110182101831018410185101861018710188101891019010191101921019310194101951019610197101981019910200102011020210203102041020510206102071020810209102101021110212102131021410215102161021710218102191022010221102221022310224102251022610227102281022910230102311023210233102341023510236102371023810239102401024110242102431024410245102461024710248102491025010251102521025310254102551025610257102581025910260102611026210263102641026510266102671026810269102701027110272102731027410275102761027710278102791028010281102821028310284102851028610287102881028910290102911029210293102941029510296102971029810299103001030110302103031030410305103061030710308103091031010311103121031310314103151031610317103181031910320103211032210323103241032510326103271032810329103301033110332103331033410335103361033710338103391034010341103421034310344103451034610347103481034910350103511035210353103541035510356103571035810359103601036110362103631036410365103661036710368103691037010371103721037310374103751037610377103781037910380103811038210383103841038510386103871038810389103901039110392103931039410395103961039710398103991040010401104021040310404104051040610407104081040910410104111041210413104141041510416104171041810419104201042110422104231042410425104261042710428104291043010431104321043310434104351043610437104381043910440104411044210443104441044510446104471044810449104501045110452104531045410455104561045710458104591046010461104621046310464104651046610467104681046910470104711047210473104741047510476104771047810479104801048110482104831048410485104861048710488104891049010491104921049310494104951049610497104981049910500105011050210503105041050510506105071050810509105101051110512105131051410515105161051710518105191052010521105221052310524105251052610527105281052910530105311053210533105341053510536105371053810539105401054110542105431054410545105461054710548105491055010551105521055310554105551055610557105581055910560105611056210563105641056510566105671056810569105701057110572105731057410575105761057710578105791058010581105821058310584105851058610587105881058910590105911059210593105941059510596105971059810599106001060110602106031060410605106061060710608106091061010611106121061310614106151061610617106181061910620106211062210623106241062510626106271062810629106301063110632106331063410635106361063710638106391064010641106421064310644106451064610647106481064910650106511065210653106541065510656106571065810659106601066110662106631066410665106661066710668106691067010671106721067310674106751067610677106781067910680106811068210683106841068510686106871068810689106901069110692106931069410695106961069710698106991070010701107021070310704107051070610707107081070910710107111071210713107141071510716107171071810719107201072110722107231072410725107261072710728107291073010731107321073310734107351073610737107381073910740107411074210743107441074510746107471074810749107501075110752107531075410755107561075710758107591076010761107621076310764107651076610767107681076910770107711077210773107741077510776107771077810779107801078110782107831078410785107861078710788107891079010791107921079310794107951079610797107981079910800108011080210803108041080510806108071080810809108101081110812108131081410815108161081710818108191082010821108221082310824108251082610827108281082910830108311083210833108341083510836108371083810839108401084110842108431084410845108461084710848108491085010851108521085310854108551085610857108581085910860108611086210863108641086510866108671086810869108701087110872108731087410875108761087710878108791088010881108821088310884108851088610887108881088910890108911089210893108941089510896108971089810899109001090110902109031090410905109061090710908109091091010911109121091310914109151091610917109181091910920109211092210923109241092510926109271092810929109301093110932109331093410935109361093710938109391094010941109421094310944109451094610947109481094910950109511095210953109541095510956109571095810959109601096110962109631096410965109661096710968109691097010971109721097310974109751097610977109781097910980109811098210983109841098510986109871098810989109901099110992109931099410995109961099710998109991100011001110021100311004110051100611007110081100911010110111101211013110141101511016110171101811019110201102111022110231102411025110261102711028110291103011031110321103311034110351103611037110381103911040110411104211043110441104511046110471104811049110501105111052110531105411055110561105711058110591106011061110621106311064110651106611067110681106911070110711107211073110741107511076110771107811079110801108111082110831108411085110861108711088110891109011091110921109311094110951109611097110981109911100111011110211103111041110511106111071110811109111101111111112111131111411115111161111711118111191112011121111221112311124111251112611127111281112911130111311113211133111341113511136111371113811139111401114111142111431114411145111461114711148111491115011151111521115311154111551115611157111581115911160111611116211163111641116511166111671116811169111701117111172111731117411175111761117711178111791118011181111821118311184111851118611187111881118911190111911119211193111941119511196111971119811199112001120111202112031120411205112061120711208112091121011211112121121311214112151121611217112181121911220112211122211223112241122511226112271122811229112301123111232112331123411235112361123711238112391124011241112421124311244112451124611247112481124911250112511125211253112541125511256112571125811259112601126111262112631126411265112661126711268112691127011271112721127311274112751127611277112781127911280112811128211283112841128511286112871128811289112901129111292112931129411295112961129711298112991130011301113021130311304113051130611307113081130911310113111131211313113141131511316113171131811319113201132111322113231132411325113261132711328113291133011331113321133311334113351133611337113381133911340113411134211343113441134511346113471134811349113501135111352113531135411355113561135711358113591136011361113621136311364113651136611367113681136911370113711137211373113741137511376113771137811379113801138111382113831138411385113861138711388113891139011391113921139311394113951139611397113981139911400114011140211403114041140511406114071140811409114101141111412114131141411415114161141711418114191142011421114221142311424114251142611427114281142911430114311143211433114341143511436114371143811439114401144111442114431144411445114461144711448114491145011451114521145311454114551145611457114581145911460114611146211463114641146511466114671146811469114701147111472114731147411475114761147711478114791148011481114821148311484114851148611487114881148911490114911149211493114941149511496114971149811499115001150111502115031150411505115061150711508115091151011511115121151311514115151151611517115181151911520115211152211523115241152511526115271152811529115301153111532115331153411535115361153711538115391154011541115421154311544115451154611547115481154911550115511155211553115541155511556115571155811559115601156111562115631156411565115661156711568115691157011571115721157311574115751157611577115781157911580115811158211583115841158511586115871158811589115901159111592115931159411595115961159711598115991160011601116021160311604116051160611607116081160911610116111161211613116141161511616116171161811619116201162111622116231162411625116261162711628116291163011631116321163311634116351163611637116381163911640116411164211643116441164511646116471164811649116501165111652116531165411655116561165711658116591166011661116621166311664116651166611667116681166911670116711167211673116741167511676116771167811679116801168111682116831168411685116861168711688116891169011691116921169311694116951169611697116981169911700117011170211703117041170511706117071170811709117101171111712117131171411715117161171711718117191172011721117221172311724117251172611727117281172911730117311173211733117341173511736117371173811739117401174111742117431174411745117461174711748117491175011751117521175311754117551175611757117581175911760117611176211763117641176511766117671176811769117701177111772117731177411775117761177711778117791178011781117821178311784117851178611787117881178911790117911179211793117941179511796117971179811799118001180111802118031180411805118061180711808118091181011811118121181311814118151181611817118181181911820118211182211823118241182511826118271182811829118301183111832118331183411835118361183711838118391184011841118421184311844118451184611847118481184911850118511185211853118541185511856118571185811859118601186111862118631186411865118661186711868118691187011871118721187311874118751187611877118781187911880118811188211883118841188511886118871188811889118901189111892118931189411895118961189711898118991190011901119021190311904119051190611907119081190911910119111191211913119141191511916119171191811919119201192111922119231192411925119261192711928119291193011931119321193311934119351193611937119381193911940119411194211943119441194511946119471194811949119501195111952119531195411955119561195711958119591196011961119621196311964119651196611967119681196911970119711197211973119741197511976119771197811979119801198111982119831198411985119861198711988119891199011991119921199311994119951199611997119981199912000120011200212003120041200512006120071200812009120101201112012120131201412015120161201712018120191202012021120221202312024120251202612027120281202912030120311203212033120341203512036120371203812039120401204112042120431204412045120461204712048120491205012051120521205312054120551205612057120581205912060120611206212063120641206512066120671206812069120701207112072120731207412075120761207712078120791208012081120821208312084120851208612087120881208912090120911209212093120941209512096120971209812099121001210112102121031210412105121061210712108121091211012111121121211312114121151211612117121181211912120121211212212123121241212512126121271212812129121301213112132121331213412135121361213712138121391214012141121421214312144121451214612147121481214912150121511215212153121541215512156121571215812159121601216112162121631216412165121661216712168121691217012171121721217312174121751217612177121781217912180121811218212183121841218512186121871218812189121901219112192121931219412195121961219712198121991220012201122021220312204122051220612207122081220912210122111221212213122141221512216122171221812219122201222112222122231222412225122261222712228122291223012231122321223312234122351223612237122381223912240122411224212243122441224512246122471224812249122501225112252122531225412255122561225712258122591226012261122621226312264122651226612267122681226912270122711227212273122741227512276122771227812279122801228112282122831228412285122861228712288122891229012291122921229312294122951229612297122981229912300123011230212303123041230512306123071230812309123101231112312123131231412315123161231712318123191232012321123221232312324123251232612327123281232912330123311233212333123341233512336123371233812339123401234112342123431234412345123461234712348123491235012351123521235312354123551235612357123581235912360123611236212363123641236512366123671236812369123701237112372123731237412375123761237712378123791238012381123821238312384123851238612387123881238912390123911239212393123941239512396123971239812399124001240112402124031240412405124061240712408124091241012411124121241312414124151241612417124181241912420124211242212423124241242512426124271242812429124301243112432124331243412435124361243712438124391244012441124421244312444124451244612447124481244912450124511245212453124541245512456124571245812459124601246112462124631246412465124661246712468124691247012471124721247312474124751247612477124781247912480124811248212483124841248512486124871248812489124901249112492124931249412495124961249712498124991250012501125021250312504125051250612507125081250912510125111251212513125141251512516125171251812519125201252112522125231252412525125261252712528125291253012531125321253312534125351253612537125381253912540125411254212543125441254512546125471254812549125501255112552125531255412555125561255712558125591256012561125621256312564125651256612567125681256912570125711257212573125741257512576125771257812579125801258112582125831258412585125861258712588125891259012591125921259312594125951259612597125981259912600126011260212603126041260512606126071260812609126101261112612126131261412615126161261712618126191262012621126221262312624126251262612627126281262912630126311263212633126341263512636126371263812639126401264112642126431264412645126461264712648126491265012651126521265312654126551265612657126581265912660126611266212663126641266512666126671266812669126701267112672126731267412675126761267712678126791268012681126821268312684126851268612687126881268912690126911269212693126941269512696126971269812699127001270112702127031270412705127061270712708127091271012711127121271312714127151271612717127181271912720127211272212723127241272512726127271272812729127301273112732127331273412735127361273712738127391274012741127421274312744127451274612747127481274912750127511275212753127541275512756127571275812759127601276112762127631276412765127661276712768127691277012771127721277312774127751277612777127781277912780127811278212783127841278512786127871278812789127901279112792127931279412795127961279712798127991280012801128021280312804128051280612807128081280912810128111281212813128141281512816128171281812819128201282112822128231282412825128261282712828128291283012831128321283312834128351283612837128381283912840128411284212843128441284512846128471284812849128501285112852128531285412855128561285712858128591286012861128621286312864128651286612867128681286912870128711287212873128741287512876128771287812879128801288112882128831288412885128861288712888128891289012891128921289312894128951289612897128981289912900129011290212903129041290512906129071290812909129101291112912129131291412915129161291712918129191292012921129221292312924129251292612927129281292912930129311293212933129341293512936129371293812939129401294112942129431294412945129461294712948129491295012951129521295312954129551295612957129581295912960129611296212963129641296512966129671296812969129701297112972129731297412975129761297712978129791298012981129821298312984129851298612987129881298912990129911299212993129941299512996129971299812999130001300113002130031300413005130061300713008130091301013011130121301313014130151301613017130181301913020130211302213023130241302513026130271302813029130301303113032130331303413035130361303713038130391304013041130421304313044130451304613047130481304913050130511305213053130541305513056130571305813059130601306113062130631306413065130661306713068130691307013071130721307313074130751307613077130781307913080130811308213083130841308513086130871308813089130901309113092130931309413095130961309713098130991310013101131021310313104131051310613107131081310913110131111311213113131141311513116131171311813119131201312113122131231312413125131261312713128131291313013131131321313313134131351313613137131381313913140131411314213143131441314513146131471314813149131501315113152131531315413155131561315713158131591316013161131621316313164131651316613167131681316913170131711317213173131741317513176131771317813179131801318113182131831318413185131861318713188131891319013191131921319313194131951319613197131981319913200132011320213203132041320513206132071320813209132101321113212132131321413215132161321713218132191322013221132221322313224132251322613227132281322913230132311323213233132341323513236132371323813239132401324113242132431324413245132461324713248132491325013251132521325313254132551325613257132581325913260132611326213263132641326513266132671326813269132701327113272132731327413275132761327713278132791328013281132821328313284132851328613287132881328913290132911329213293132941329513296132971329813299133001330113302133031330413305133061330713308133091331013311133121331313314133151331613317133181331913320133211332213323133241332513326133271332813329133301333113332133331333413335133361333713338133391334013341133421334313344133451334613347133481334913350133511335213353133541335513356133571335813359133601336113362133631336413365133661336713368133691337013371133721337313374133751337613377133781337913380133811338213383133841338513386133871338813389133901339113392133931339413395133961339713398133991340013401134021340313404134051340613407134081340913410134111341213413134141341513416134171341813419134201342113422134231342413425134261342713428134291343013431134321343313434134351343613437134381343913440134411344213443134441344513446134471344813449134501345113452134531345413455134561345713458134591346013461134621346313464134651346613467134681346913470134711347213473134741347513476134771347813479134801348113482134831348413485134861348713488134891349013491134921349313494134951349613497134981349913500135011350213503135041350513506135071350813509135101351113512135131351413515135161351713518135191352013521135221352313524135251352613527135281352913530135311353213533135341353513536135371353813539135401354113542135431354413545135461354713548135491355013551135521355313554135551355613557135581355913560135611356213563135641356513566135671356813569135701357113572135731357413575135761357713578135791358013581135821358313584135851358613587135881358913590135911359213593135941359513596135971359813599136001360113602136031360413605136061360713608136091361013611136121361313614136151361613617136181361913620136211362213623136241362513626136271362813629136301363113632136331363413635136361363713638136391364013641136421364313644136451364613647136481364913650136511365213653136541365513656136571365813659136601366113662136631366413665136661366713668136691367013671136721367313674136751367613677136781367913680136811368213683136841368513686136871368813689136901369113692136931369413695136961369713698136991370013701137021370313704137051370613707137081370913710137111371213713137141371513716137171371813719137201372113722137231372413725137261372713728137291373013731137321373313734137351373613737137381373913740137411374213743137441374513746137471374813749137501375113752137531375413755137561375713758137591376013761137621376313764137651376613767137681376913770137711377213773137741377513776137771377813779137801378113782137831378413785137861378713788137891379013791137921379313794137951379613797137981379913800138011380213803138041380513806138071380813809138101381113812138131381413815138161381713818138191382013821138221382313824138251382613827138281382913830138311383213833138341383513836138371383813839138401384113842138431384413845138461384713848138491385013851138521385313854138551385613857138581385913860138611386213863138641386513866138671386813869138701387113872138731387413875138761387713878138791388013881138821388313884138851388613887138881388913890138911389213893138941389513896138971389813899139001390113902139031390413905139061390713908139091391013911139121391313914139151391613917139181391913920139211392213923139241392513926139271392813929139301393113932139331393413935139361393713938139391394013941139421394313944139451394613947139481394913950139511395213953139541395513956139571395813959139601396113962139631396413965139661396713968139691397013971139721397313974139751397613977139781397913980139811398213983139841398513986139871398813989139901399113992139931399413995139961399713998139991400014001140021400314004140051400614007140081400914010140111401214013140141401514016140171401814019140201402114022140231402414025140261402714028140291403014031140321403314034140351403614037140381403914040140411404214043140441404514046140471404814049140501405114052140531405414055140561405714058140591406014061140621406314064140651406614067140681406914070140711407214073140741407514076140771407814079140801408114082140831408414085140861408714088140891409014091140921409314094140951409614097140981409914100141011410214103141041410514106141071410814109141101411114112141131411414115141161411714118141191412014121141221412314124141251412614127141281412914130141311413214133141341413514136141371413814139141401414114142141431414414145141461414714148141491415014151141521415314154141551415614157141581415914160141611416214163141641416514166141671416814169141701417114172141731417414175141761417714178141791418014181141821418314184141851418614187141881418914190141911419214193141941419514196141971419814199142001420114202142031420414205142061420714208142091421014211142121421314214142151421614217142181421914220142211422214223142241422514226142271422814229142301423114232142331423414235142361423714238142391424014241142421424314244142451424614247142481424914250142511425214253142541425514256142571425814259142601426114262142631426414265142661426714268142691427014271142721427314274142751427614277142781427914280142811428214283142841428514286142871428814289142901429114292142931429414295142961429714298142991430014301143021430314304143051430614307143081430914310143111431214313143141431514316143171431814319143201432114322143231432414325143261432714328143291433014331143321433314334143351433614337143381433914340143411434214343143441434514346143471434814349143501435114352143531435414355143561435714358143591436014361143621436314364143651436614367143681436914370143711437214373143741437514376143771437814379143801438114382143831438414385143861438714388143891439014391143921439314394143951439614397143981439914400144011440214403144041440514406144071440814409144101441114412144131441414415144161441714418144191442014421144221442314424144251442614427144281442914430144311443214433144341443514436144371443814439144401444114442144431444414445144461444714448144491445014451144521445314454144551445614457144581445914460144611446214463144641446514466144671446814469144701447114472144731447414475144761447714478144791448014481144821448314484144851448614487144881448914490144911449214493144941449514496144971449814499145001450114502145031450414505145061450714508145091451014511145121451314514145151451614517145181451914520145211452214523145241452514526145271452814529145301453114532145331453414535145361453714538145391454014541145421454314544145451454614547145481454914550145511455214553145541455514556145571455814559145601456114562145631456414565145661456714568145691457014571145721457314574145751457614577145781457914580145811458214583145841458514586145871458814589145901459114592145931459414595145961459714598145991460014601146021460314604146051460614607146081460914610146111461214613146141461514616146171461814619146201462114622146231462414625146261462714628146291463014631146321463314634146351463614637146381463914640146411464214643146441464514646146471464814649146501465114652146531465414655146561465714658146591466014661146621466314664146651466614667146681466914670146711467214673146741467514676146771467814679146801468114682146831468414685146861468714688146891469014691146921469314694146951469614697146981469914700147011470214703147041470514706147071470814709147101471114712147131471414715147161471714718147191472014721147221472314724147251472614727147281472914730147311473214733147341473514736147371473814739147401474114742147431474414745147461474714748147491475014751147521475314754147551475614757147581475914760147611476214763147641476514766147671476814769147701477114772147731477414775147761477714778147791478014781147821478314784147851478614787147881478914790147911479214793147941479514796147971479814799148001480114802148031480414805148061480714808148091481014811148121481314814148151481614817148181481914820148211482214823148241482514826148271482814829148301483114832148331483414835148361483714838148391484014841148421484314844148451484614847148481484914850148511485214853148541485514856148571485814859148601486114862148631486414865148661486714868148691487014871148721487314874148751487614877148781487914880148811488214883148841488514886148871488814889148901489114892148931489414895148961489714898148991490014901149021490314904149051490614907149081490914910149111491214913149141491514916149171491814919149201492114922149231492414925149261492714928149291493014931149321493314934149351493614937149381493914940149411494214943149441494514946149471494814949149501495114952149531495414955149561495714958149591496014961149621496314964149651496614967149681496914970149711497214973149741497514976149771497814979149801498114982149831498414985149861498714988149891499014991149921499314994149951499614997149981499915000150011500215003150041500515006150071500815009150101501115012150131501415015150161501715018150191502015021150221502315024150251502615027150281502915030150311503215033150341503515036150371503815039150401504115042150431504415045150461504715048150491505015051150521505315054150551505615057150581505915060150611506215063150641506515066150671506815069150701507115072150731507415075150761507715078150791508015081150821508315084150851508615087150881508915090150911509215093150941509515096150971509815099151001510115102151031510415105151061510715108151091511015111151121511315114151151511615117151181511915120151211512215123151241512515126151271512815129151301513115132151331513415135151361513715138151391514015141151421514315144151451514615147151481514915150151511515215153151541515515156151571515815159151601516115162151631516415165151661516715168151691517015171151721517315174151751517615177151781517915180151811518215183151841518515186151871518815189151901519115192151931519415195151961519715198151991520015201152021520315204152051520615207152081520915210152111521215213152141521515216152171521815219152201522115222152231522415225152261522715228152291523015231152321523315234152351523615237152381523915240152411524215243152441524515246152471524815249152501525115252152531525415255152561525715258152591526015261152621526315264152651526615267152681526915270152711527215273152741527515276152771527815279152801528115282152831528415285152861528715288152891529015291152921529315294152951529615297152981529915300153011530215303153041530515306153071530815309153101531115312153131531415315153161531715318153191532015321153221532315324153251532615327153281532915330153311533215333153341533515336153371533815339153401534115342153431534415345153461534715348153491535015351153521535315354153551535615357153581535915360153611536215363153641536515366153671536815369153701537115372153731537415375153761537715378153791538015381153821538315384153851538615387153881538915390153911539215393153941539515396153971539815399154001540115402154031540415405154061540715408154091541015411154121541315414154151541615417154181541915420154211542215423154241542515426154271542815429154301543115432154331543415435154361543715438154391544015441154421544315444154451544615447154481544915450154511545215453154541545515456154571545815459154601546115462154631546415465154661546715468154691547015471154721547315474154751547615477154781547915480154811548215483154841548515486154871548815489154901549115492154931549415495154961549715498154991550015501155021550315504155051550615507155081550915510155111551215513155141551515516155171551815519155201552115522155231552415525155261552715528155291553015531155321553315534155351553615537155381553915540155411554215543155441554515546155471554815549155501555115552155531555415555155561555715558155591556015561155621556315564155651556615567155681556915570155711557215573155741557515576155771557815579155801558115582155831558415585155861558715588155891559015591155921559315594155951559615597155981559915600156011560215603156041560515606156071560815609156101561115612156131561415615156161561715618156191562015621156221562315624156251562615627156281562915630156311563215633156341563515636156371563815639156401564115642156431564415645156461564715648156491565015651156521565315654156551565615657156581565915660156611566215663156641566515666156671566815669156701567115672156731567415675156761567715678156791568015681156821568315684156851568615687156881568915690156911569215693156941569515696156971569815699157001570115702157031570415705157061570715708157091571015711157121571315714157151571615717157181571915720157211572215723157241572515726157271572815729157301573115732157331573415735157361573715738157391574015741157421574315744157451574615747157481574915750157511575215753157541575515756157571575815759157601576115762157631576415765157661576715768157691577015771157721577315774157751577615777157781577915780157811578215783157841578515786157871578815789157901579115792157931579415795157961579715798157991580015801158021580315804158051580615807158081580915810158111581215813158141581515816158171581815819158201582115822158231582415825158261582715828158291583015831158321583315834158351583615837158381583915840158411584215843158441584515846158471584815849158501585115852158531585415855158561585715858158591586015861158621586315864158651586615867158681586915870158711587215873158741587515876158771587815879158801588115882158831588415885158861588715888158891589015891158921589315894158951589615897158981589915900159011590215903159041590515906159071590815909159101591115912159131591415915159161591715918159191592015921159221592315924159251592615927159281592915930159311593215933159341593515936159371593815939159401594115942159431594415945159461594715948159491595015951159521595315954159551595615957159581595915960159611596215963159641596515966159671596815969159701597115972159731597415975159761597715978159791598015981159821598315984159851598615987159881598915990159911599215993159941599515996159971599815999160001600116002160031600416005160061600716008160091601016011160121601316014160151601616017160181601916020160211602216023160241602516026160271602816029160301603116032160331603416035160361603716038160391604016041160421604316044160451604616047160481604916050160511605216053160541605516056160571605816059160601606116062160631606416065160661606716068160691607016071160721607316074160751607616077160781607916080160811608216083160841608516086160871608816089160901609116092160931609416095160961609716098160991610016101161021610316104161051610616107161081610916110161111611216113161141611516116161171611816119161201612116122161231612416125161261612716128161291613016131161321613316134161351613616137161381613916140161411614216143161441614516146161471614816149161501615116152161531615416155161561615716158161591616016161161621616316164161651616616167161681616916170161711617216173161741617516176161771617816179161801618116182161831618416185161861618716188161891619016191161921619316194161951619616197161981619916200162011620216203162041620516206162071620816209162101621116212162131621416215162161621716218162191622016221162221622316224162251622616227162281622916230162311623216233162341623516236162371623816239162401624116242162431624416245162461624716248162491625016251162521625316254162551625616257162581625916260162611626216263162641626516266162671626816269162701627116272162731627416275162761627716278162791628016281162821628316284162851628616287162881628916290162911629216293162941629516296162971629816299163001630116302163031630416305163061630716308163091631016311163121631316314163151631616317163181631916320163211632216323163241632516326163271632816329163301633116332163331633416335163361633716338163391634016341163421634316344163451634616347163481634916350163511635216353163541635516356163571635816359163601636116362163631636416365163661636716368163691637016371163721637316374163751637616377163781637916380163811638216383163841638516386163871638816389163901639116392163931639416395163961639716398163991640016401164021640316404164051640616407164081640916410164111641216413164141641516416164171641816419164201642116422164231642416425164261642716428164291643016431164321643316434164351643616437164381643916440164411644216443164441644516446164471644816449164501645116452164531645416455164561645716458164591646016461164621646316464164651646616467164681646916470164711647216473164741647516476164771647816479164801648116482164831648416485164861648716488164891649016491164921649316494164951649616497164981649916500165011650216503165041650516506165071650816509165101651116512165131651416515165161651716518165191652016521165221652316524165251652616527165281652916530165311653216533165341653516536165371653816539165401654116542165431654416545165461654716548165491655016551165521655316554165551655616557165581655916560165611656216563165641656516566165671656816569165701657116572165731657416575165761657716578165791658016581165821658316584165851658616587165881658916590165911659216593165941659516596165971659816599166001660116602166031660416605166061660716608166091661016611166121661316614166151661616617166181661916620166211662216623166241662516626166271662816629166301663116632166331663416635166361663716638166391664016641166421664316644166451664616647166481664916650166511665216653166541665516656166571665816659166601666116662166631666416665166661666716668166691667016671166721667316674166751667616677166781667916680166811668216683166841668516686166871668816689166901669116692166931669416695166961669716698166991670016701167021670316704167051670616707167081670916710167111671216713167141671516716167171671816719167201672116722167231672416725167261672716728167291673016731167321673316734167351673616737167381673916740167411674216743167441674516746167471674816749167501675116752167531675416755167561675716758167591676016761167621676316764167651676616767167681676916770167711677216773167741677516776167771677816779167801678116782167831678416785167861678716788167891679016791167921679316794167951679616797167981679916800168011680216803168041680516806168071680816809168101681116812168131681416815168161681716818168191682016821168221682316824168251682616827168281682916830168311683216833168341683516836168371683816839168401684116842168431684416845168461684716848168491685016851168521685316854168551685616857168581685916860168611686216863168641686516866168671686816869168701687116872168731687416875168761687716878168791688016881168821688316884168851688616887168881688916890168911689216893168941689516896168971689816899169001690116902169031690416905169061690716908169091691016911169121691316914169151691616917169181691916920169211692216923169241692516926169271692816929169301693116932169331693416935169361693716938169391694016941169421694316944169451694616947169481694916950169511695216953169541695516956169571695816959169601696116962169631696416965169661696716968169691697016971169721697316974169751697616977169781697916980169811698216983169841698516986169871698816989169901699116992169931699416995169961699716998169991700017001170021700317004170051700617007170081700917010170111701217013170141701517016170171701817019170201702117022170231702417025170261702717028170291703017031170321703317034170351703617037170381703917040170411704217043170441704517046170471704817049170501705117052170531705417055170561705717058170591706017061170621706317064170651706617067170681706917070170711707217073170741707517076170771707817079170801708117082170831708417085170861708717088170891709017091170921709317094170951709617097170981709917100171011710217103171041710517106171071710817109171101711117112171131711417115171161711717118171191712017121171221712317124171251712617127171281712917130171311713217133171341713517136171371713817139171401714117142171431714417145171461714717148171491715017151171521715317154171551715617157171581715917160171611716217163171641716517166171671716817169171701717117172171731717417175171761717717178171791718017181171821718317184171851718617187171881718917190171911719217193171941719517196171971719817199172001720117202172031720417205172061720717208172091721017211172121721317214172151721617217172181721917220172211722217223172241722517226172271722817229172301723117232172331723417235172361723717238172391724017241172421724317244172451724617247172481724917250172511725217253172541725517256172571725817259172601726117262172631726417265172661726717268172691727017271172721727317274172751727617277172781727917280172811728217283172841728517286172871728817289172901729117292172931729417295172961729717298172991730017301173021730317304173051730617307173081730917310173111731217313173141731517316173171731817319173201732117322173231732417325173261732717328173291733017331173321733317334173351733617337173381733917340173411734217343173441734517346173471734817349173501735117352173531735417355173561735717358173591736017361173621736317364173651736617367173681736917370173711737217373173741737517376173771737817379173801738117382173831738417385173861738717388173891739017391173921739317394173951739617397173981739917400174011740217403174041740517406174071740817409174101741117412174131741417415174161741717418174191742017421174221742317424174251742617427174281742917430174311743217433174341743517436174371743817439174401744117442174431744417445174461744717448174491745017451174521745317454174551745617457174581745917460174611746217463174641746517466174671746817469174701747117472174731747417475174761747717478174791748017481174821748317484174851748617487174881748917490174911749217493174941749517496174971749817499175001750117502175031750417505175061750717508175091751017511175121751317514175151751617517175181751917520175211752217523175241752517526175271752817529175301753117532175331753417535175361753717538175391754017541175421754317544175451754617547175481754917550175511755217553175541755517556175571755817559175601756117562175631756417565175661756717568175691757017571175721757317574175751757617577175781757917580175811758217583175841758517586175871758817589175901759117592175931759417595175961759717598175991760017601176021760317604176051760617607176081760917610176111761217613176141761517616176171761817619176201762117622176231762417625176261762717628176291763017631176321763317634176351763617637176381763917640176411764217643176441764517646176471764817649176501765117652176531765417655176561765717658176591766017661176621766317664176651766617667176681766917670176711767217673176741767517676176771767817679176801768117682176831768417685176861768717688176891769017691176921769317694176951769617697176981769917700177011770217703177041770517706177071770817709177101771117712177131771417715177161771717718177191772017721177221772317724177251772617727177281772917730177311773217733177341773517736177371773817739177401774117742177431774417745177461774717748177491775017751177521775317754177551775617757177581775917760177611776217763177641776517766177671776817769177701777117772177731777417775177761777717778177791778017781177821778317784177851778617787177881778917790177911779217793177941779517796177971779817799178001780117802178031780417805178061780717808178091781017811178121781317814178151781617817178181781917820178211782217823178241782517826178271782817829178301783117832178331783417835178361783717838178391784017841178421784317844178451784617847178481784917850178511785217853178541785517856178571785817859178601786117862178631786417865178661786717868178691787017871178721787317874178751787617877178781787917880178811788217883178841788517886178871788817889178901789117892178931789417895178961789717898178991790017901179021790317904179051790617907179081790917910179111791217913179141791517916179171791817919179201792117922179231792417925179261792717928179291793017931179321793317934179351793617937179381793917940179411794217943179441794517946179471794817949179501795117952179531795417955179561795717958179591796017961179621796317964179651796617967179681796917970179711797217973179741797517976179771797817979179801798117982179831798417985179861798717988179891799017991179921799317994179951799617997179981799918000180011800218003180041800518006180071800818009180101801118012180131801418015180161801718018180191802018021180221802318024180251802618027180281802918030180311803218033180341803518036180371803818039180401804118042180431804418045180461804718048180491805018051180521805318054180551805618057180581805918060180611806218063180641806518066180671806818069180701807118072180731807418075180761807718078180791808018081180821808318084180851808618087180881808918090180911809218093180941809518096180971809818099181001810118102181031810418105181061810718108181091811018111181121811318114181151811618117181181811918120181211812218123181241812518126181271812818129181301813118132181331813418135181361813718138181391814018141181421814318144181451814618147181481814918150181511815218153181541815518156181571815818159181601816118162181631816418165181661816718168181691817018171181721817318174181751817618177181781817918180181811818218183181841818518186181871818818189181901819118192181931819418195181961819718198181991820018201182021820318204182051820618207182081820918210182111821218213182141821518216182171821818219182201822118222182231822418225182261822718228182291823018231182321823318234182351823618237182381823918240182411824218243182441824518246182471824818249182501825118252182531825418255182561825718258182591826018261182621826318264182651826618267182681826918270182711827218273182741827518276182771827818279182801828118282182831828418285182861828718288182891829018291182921829318294182951829618297182981829918300183011830218303183041830518306183071830818309183101831118312183131831418315183161831718318183191832018321183221832318324183251832618327183281832918330183311833218333183341833518336183371833818339183401834118342183431834418345183461834718348183491835018351183521835318354183551835618357183581835918360183611836218363183641836518366183671836818369183701837118372183731837418375183761837718378183791838018381183821838318384183851838618387183881838918390183911839218393183941839518396183971839818399184001840118402184031840418405184061840718408184091841018411184121841318414184151841618417184181841918420184211842218423184241842518426184271842818429184301843118432184331843418435184361843718438184391844018441184421844318444184451844618447184481844918450184511845218453184541845518456184571845818459184601846118462184631846418465184661846718468184691847018471184721847318474184751847618477184781847918480184811848218483184841848518486184871848818489184901849118492184931849418495184961849718498184991850018501185021850318504185051850618507185081850918510185111851218513185141851518516185171851818519185201852118522185231852418525185261852718528185291853018531185321853318534185351853618537185381853918540185411854218543185441854518546185471854818549185501855118552185531855418555185561855718558185591856018561185621856318564185651856618567185681856918570185711857218573185741857518576185771857818579185801858118582185831858418585185861858718588185891859018591185921859318594185951859618597185981859918600186011860218603186041860518606186071860818609186101861118612186131861418615186161861718618186191862018621186221862318624186251862618627186281862918630186311863218633186341863518636186371863818639186401864118642186431864418645186461864718648186491865018651186521865318654186551865618657186581865918660186611866218663186641866518666186671866818669186701867118672186731867418675186761867718678186791868018681186821868318684186851868618687186881868918690186911869218693186941869518696186971869818699187001870118702187031870418705187061870718708187091871018711187121871318714187151871618717187181871918720187211872218723187241872518726187271872818729187301873118732187331873418735187361873718738187391874018741187421874318744187451874618747187481874918750187511875218753187541875518756187571875818759187601876118762187631876418765187661876718768187691877018771187721877318774187751877618777187781877918780187811878218783187841878518786187871878818789187901879118792187931879418795187961879718798187991880018801188021880318804188051880618807188081880918810188111881218813188141881518816188171881818819188201882118822188231882418825188261882718828188291883018831188321883318834188351883618837188381883918840188411884218843188441884518846188471884818849188501885118852188531885418855188561885718858188591886018861188621886318864188651886618867188681886918870188711887218873188741887518876188771887818879188801888118882188831888418885188861888718888188891889018891188921889318894188951889618897188981889918900189011890218903189041890518906189071890818909189101891118912189131891418915189161891718918189191892018921189221892318924189251892618927189281892918930189311893218933189341893518936189371893818939189401894118942189431894418945189461894718948189491895018951189521895318954189551895618957189581895918960189611896218963189641896518966189671896818969189701897118972189731897418975189761897718978189791898018981189821898318984189851898618987189881898918990189911899218993189941899518996189971899818999190001900119002190031900419005190061900719008190091901019011190121901319014190151901619017190181901919020190211902219023190241902519026190271902819029190301903119032190331903419035190361903719038190391904019041190421904319044190451904619047190481904919050190511905219053190541905519056190571905819059190601906119062190631906419065190661906719068190691907019071190721907319074190751907619077190781907919080190811908219083190841908519086190871908819089190901909119092190931909419095190961909719098190991910019101191021910319104191051910619107191081910919110191111911219113191141911519116191171911819119191201912119122191231912419125191261912719128191291913019131191321913319134191351913619137191381913919140191411914219143191441914519146191471914819149191501915119152191531915419155191561915719158191591916019161191621916319164191651916619167191681916919170191711917219173191741917519176191771917819179191801918119182191831918419185191861918719188191891919019191191921919319194191951919619197191981919919200192011920219203192041920519206192071920819209192101921119212192131921419215192161921719218192191922019221192221922319224192251922619227192281922919230192311923219233192341923519236192371923819239192401924119242192431924419245192461924719248192491925019251192521925319254192551925619257192581925919260192611926219263192641926519266192671926819269192701927119272192731927419275192761927719278192791928019281192821928319284192851928619287192881928919290192911929219293192941929519296192971929819299193001930119302193031930419305193061930719308193091931019311193121931319314193151931619317193181931919320193211932219323193241932519326193271932819329193301933119332193331933419335193361933719338193391934019341193421934319344193451934619347193481934919350193511935219353193541935519356193571935819359193601936119362193631936419365193661936719368193691937019371193721937319374193751937619377193781937919380193811938219383193841938519386193871938819389193901939119392193931939419395193961939719398193991940019401194021940319404194051940619407194081940919410194111941219413194141941519416194171941819419194201942119422194231942419425194261942719428194291943019431194321943319434194351943619437194381943919440194411944219443194441944519446194471944819449194501945119452194531945419455194561945719458194591946019461194621946319464194651946619467194681946919470194711947219473194741947519476194771947819479194801948119482194831948419485194861948719488194891949019491194921949319494194951949619497194981949919500195011950219503195041950519506195071950819509195101951119512195131951419515195161951719518195191952019521195221952319524195251952619527195281952919530195311953219533195341953519536195371953819539195401954119542195431954419545195461954719548195491955019551195521955319554195551955619557195581955919560195611956219563195641956519566195671956819569195701957119572195731957419575195761957719578195791958019581195821958319584195851958619587195881958919590195911959219593195941959519596195971959819599196001960119602196031960419605196061960719608196091961019611196121961319614196151961619617196181961919620196211962219623196241962519626196271962819629196301963119632196331963419635196361963719638196391964019641196421964319644196451964619647196481964919650196511965219653196541965519656196571965819659196601966119662196631966419665196661966719668196691967019671196721967319674196751967619677196781967919680196811968219683196841968519686196871968819689196901969119692196931969419695196961969719698196991970019701197021970319704197051970619707197081970919710197111971219713197141971519716197171971819719197201972119722197231972419725197261972719728197291973019731197321973319734197351973619737197381973919740197411974219743197441974519746197471974819749197501975119752197531975419755197561975719758197591976019761197621976319764197651976619767197681976919770197711977219773197741977519776197771977819779197801978119782197831978419785197861978719788197891979019791197921979319794197951979619797197981979919800198011980219803198041980519806198071980819809198101981119812198131981419815198161981719818198191982019821198221982319824198251982619827198281982919830198311983219833198341983519836198371983819839198401984119842198431984419845198461984719848198491985019851198521985319854198551985619857198581985919860198611986219863198641986519866198671986819869198701987119872198731987419875198761987719878198791988019881198821988319884198851988619887198881988919890198911989219893198941989519896198971989819899199001990119902199031990419905199061990719908199091991019911199121991319914199151991619917199181991919920199211992219923199241992519926199271992819929199301993119932199331993419935199361993719938199391994019941199421994319944199451994619947199481994919950199511995219953199541995519956199571995819959199601996119962199631996419965199661996719968199691997019971199721997319974199751997619977199781997919980199811998219983199841998519986199871998819989199901999119992199931999419995199961999719998199992000020001200022000320004200052000620007200082000920010200112001220013200142001520016200172001820019200202002120022200232002420025200262002720028200292003020031200322003320034200352003620037200382003920040200412004220043200442004520046200472004820049200502005120052200532005420055200562005720058200592006020061200622006320064200652006620067200682006920070200712007220073200742007520076200772007820079200802008120082200832008420085200862008720088200892009020091200922009320094200952009620097200982009920100201012010220103201042010520106201072010820109201102011120112201132011420115201162011720118201192012020121201222012320124201252012620127201282012920130201312013220133201342013520136201372013820139201402014120142201432014420145201462014720148201492015020151201522015320154201552015620157201582015920160201612016220163201642016520166201672016820169201702017120172201732017420175201762017720178201792018020181201822018320184201852018620187201882018920190201912019220193201942019520196201972019820199202002020120202202032020420205202062020720208202092021020211202122021320214202152021620217202182021920220202212022220223202242022520226202272022820229202302023120232202332023420235202362023720238202392024020241202422024320244202452024620247202482024920250202512025220253202542025520256202572025820259202602026120262202632026420265202662026720268202692027020271202722027320274202752027620277202782027920280202812028220283202842028520286202872028820289202902029120292202932029420295202962029720298202992030020301203022030320304203052030620307203082030920310203112031220313203142031520316203172031820319203202032120322203232032420325203262032720328203292033020331203322033320334203352033620337203382033920340203412034220343203442034520346203472034820349203502035120352203532035420355203562035720358203592036020361203622036320364203652036620367203682036920370203712037220373203742037520376203772037820379203802038120382203832038420385203862038720388203892039020391203922039320394203952039620397203982039920400204012040220403204042040520406204072040820409204102041120412204132041420415204162041720418204192042020421204222042320424204252042620427204282042920430204312043220433204342043520436204372043820439204402044120442204432044420445204462044720448204492045020451204522045320454204552045620457204582045920460204612046220463204642046520466204672046820469204702047120472204732047420475204762047720478204792048020481204822048320484204852048620487204882048920490204912049220493204942049520496204972049820499205002050120502205032050420505205062050720508205092051020511205122051320514205152051620517205182051920520205212052220523205242052520526205272052820529205302053120532205332053420535205362053720538205392054020541205422054320544205452054620547205482054920550205512055220553205542055520556205572055820559205602056120562205632056420565205662056720568205692057020571205722057320574205752057620577205782057920580205812058220583205842058520586205872058820589205902059120592205932059420595205962059720598205992060020601206022060320604206052060620607206082060920610206112061220613206142061520616206172061820619206202062120622206232062420625206262062720628206292063020631206322063320634206352063620637206382063920640206412064220643206442064520646206472064820649206502065120652206532065420655206562065720658206592066020661206622066320664206652066620667206682066920670206712067220673206742067520676206772067820679206802068120682206832068420685206862068720688206892069020691206922069320694206952069620697206982069920700207012070220703207042070520706207072070820709207102071120712207132071420715207162071720718207192072020721207222072320724207252072620727207282072920730207312073220733207342073520736207372073820739207402074120742207432074420745207462074720748207492075020751207522075320754207552075620757207582075920760207612076220763207642076520766207672076820769207702077120772207732077420775207762077720778207792078020781207822078320784207852078620787207882078920790207912079220793207942079520796207972079820799208002080120802208032080420805208062080720808208092081020811208122081320814208152081620817208182081920820208212082220823208242082520826208272082820829208302083120832208332083420835208362083720838208392084020841208422084320844208452084620847208482084920850208512085220853208542085520856208572085820859208602086120862208632086420865208662086720868208692087020871208722087320874208752087620877208782087920880208812088220883208842088520886208872088820889208902089120892208932089420895208962089720898208992090020901209022090320904209052090620907209082090920910209112091220913209142091520916209172091820919209202092120922209232092420925209262092720928209292093020931209322093320934209352093620937209382093920940209412094220943209442094520946209472094820949209502095120952209532095420955209562095720958209592096020961209622096320964209652096620967209682096920970209712097220973209742097520976209772097820979209802098120982209832098420985209862098720988209892099020991209922099320994209952099620997209982099921000210012100221003210042100521006210072100821009210102101121012210132101421015210162101721018210192102021021210222102321024210252102621027210282102921030210312103221033210342103521036210372103821039210402104121042210432104421045210462104721048210492105021051210522105321054210552105621057210582105921060210612106221063210642106521066210672106821069210702107121072210732107421075210762107721078210792108021081210822108321084210852108621087210882108921090210912109221093210942109521096210972109821099211002110121102211032110421105211062110721108211092111021111211122111321114211152111621117211182111921120211212112221123211242112521126211272112821129211302113121132211332113421135211362113721138211392114021141211422114321144211452114621147211482114921150211512115221153211542115521156211572115821159211602116121162211632116421165211662116721168211692117021171211722117321174211752117621177211782117921180211812118221183211842118521186211872118821189211902119121192211932119421195211962119721198211992120021201212022120321204212052120621207212082120921210212112121221213212142121521216212172121821219212202122121222212232122421225212262122721228212292123021231212322123321234212352123621237212382123921240212412124221243212442124521246212472124821249212502125121252212532125421255212562125721258212592126021261212622126321264212652126621267212682126921270212712127221273212742127521276212772127821279212802128121282212832128421285212862128721288212892129021291212922129321294212952129621297212982129921300213012130221303213042130521306213072130821309213102131121312213132131421315213162131721318213192132021321213222132321324213252132621327213282132921330213312133221333213342133521336213372133821339213402134121342213432134421345213462134721348213492135021351213522135321354213552135621357213582135921360213612136221363213642136521366213672136821369213702137121372213732137421375213762137721378213792138021381213822138321384213852138621387213882138921390213912139221393213942139521396213972139821399214002140121402214032140421405214062140721408214092141021411214122141321414214152141621417214182141921420214212142221423214242142521426214272142821429214302143121432214332143421435214362143721438214392144021441214422144321444214452144621447214482144921450214512145221453214542145521456214572145821459214602146121462214632146421465214662146721468214692147021471214722147321474214752147621477214782147921480214812148221483214842148521486214872148821489214902149121492214932149421495214962149721498214992150021501215022150321504215052150621507215082150921510215112151221513215142151521516215172151821519215202152121522215232152421525215262152721528215292153021531215322153321534215352153621537215382153921540215412154221543215442154521546215472154821549215502155121552215532155421555215562155721558215592156021561215622156321564215652156621567215682156921570215712157221573215742157521576215772157821579215802158121582215832158421585215862158721588215892159021591215922159321594215952159621597215982159921600216012160221603216042160521606216072160821609216102161121612216132161421615216162161721618216192162021621216222162321624216252162621627216282162921630216312163221633216342163521636216372163821639216402164121642216432164421645216462164721648216492165021651216522165321654216552165621657216582165921660216612166221663216642166521666216672166821669216702167121672216732167421675216762167721678216792168021681216822168321684216852168621687216882168921690216912169221693216942169521696216972169821699217002170121702217032170421705217062170721708217092171021711217122171321714217152171621717217182171921720217212172221723217242172521726217272172821729217302173121732217332173421735217362173721738217392174021741217422174321744217452174621747217482174921750217512175221753217542175521756217572175821759217602176121762217632176421765217662176721768217692177021771217722177321774217752177621777217782177921780217812178221783217842178521786217872178821789217902179121792217932179421795217962179721798217992180021801218022180321804218052180621807218082180921810218112181221813218142181521816218172181821819218202182121822218232182421825218262182721828218292183021831218322183321834218352183621837218382183921840218412184221843218442184521846218472184821849218502185121852218532185421855218562185721858218592186021861218622186321864218652186621867218682186921870218712187221873218742187521876218772187821879218802188121882218832188421885218862188721888218892189021891218922189321894218952189621897218982189921900219012190221903219042190521906219072190821909219102191121912219132191421915219162191721918219192192021921219222192321924219252192621927219282192921930219312193221933219342193521936219372193821939219402194121942219432194421945219462194721948219492195021951219522195321954219552195621957219582195921960219612196221963219642196521966219672196821969219702197121972219732197421975219762197721978219792198021981219822198321984219852198621987219882198921990219912199221993219942199521996219972199821999220002200122002220032200422005220062200722008220092201022011220122201322014220152201622017220182201922020220212202222023220242202522026220272202822029220302203122032220332203422035220362203722038220392204022041220422204322044220452204622047220482204922050220512205222053220542205522056220572205822059220602206122062220632206422065220662206722068220692207022071220722207322074220752207622077220782207922080220812208222083220842208522086220872208822089220902209122092220932209422095220962209722098220992210022101221022210322104221052210622107221082210922110221112211222113221142211522116221172211822119221202212122122221232212422125221262212722128221292213022131221322213322134221352213622137221382213922140221412214222143221442214522146221472214822149221502215122152221532215422155221562215722158221592216022161221622216322164221652216622167221682216922170221712217222173221742217522176221772217822179221802218122182221832218422185221862218722188221892219022191221922219322194221952219622197221982219922200222012220222203222042220522206222072220822209222102221122212222132221422215222162221722218222192222022221222222222322224222252222622227222282222922230222312223222233222342223522236222372223822239222402224122242222432224422245222462224722248222492225022251222522225322254222552225622257222582225922260222612226222263222642226522266222672226822269222702227122272222732227422275222762227722278222792228022281222822228322284222852228622287222882228922290222912229222293222942229522296222972229822299223002230122302223032230422305223062230722308223092231022311223122231322314223152231622317223182231922320223212232222323223242232522326223272232822329223302233122332223332233422335223362233722338223392234022341223422234322344223452234622347223482234922350223512235222353223542235522356223572235822359223602236122362223632236422365223662236722368223692237022371223722237322374223752237622377223782237922380223812238222383223842238522386223872238822389223902239122392223932239422395223962239722398223992240022401224022240322404224052240622407224082240922410224112241222413224142241522416224172241822419224202242122422224232242422425224262242722428224292243022431224322243322434224352243622437224382243922440224412244222443224442244522446224472244822449224502245122452224532245422455224562245722458224592246022461224622246322464224652246622467224682246922470224712247222473224742247522476224772247822479224802248122482224832248422485224862248722488224892249022491224922249322494224952249622497224982249922500225012250222503225042250522506225072250822509225102251122512225132251422515225162251722518225192252022521225222252322524225252252622527225282252922530225312253222533225342253522536225372253822539225402254122542225432254422545225462254722548225492255022551225522255322554225552255622557225582255922560225612256222563225642256522566225672256822569225702257122572225732257422575225762257722578225792258022581225822258322584225852258622587225882258922590225912259222593225942259522596225972259822599226002260122602226032260422605226062260722608226092261022611226122261322614226152261622617226182261922620226212262222623226242262522626226272262822629226302263122632226332263422635226362263722638226392264022641226422264322644226452264622647226482264922650226512265222653226542265522656226572265822659226602266122662226632266422665226662266722668226692267022671226722267322674226752267622677226782267922680226812268222683226842268522686226872268822689226902269122692226932269422695226962269722698226992270022701227022270322704227052270622707227082270922710227112271222713227142271522716227172271822719227202272122722227232272422725227262272722728227292273022731227322273322734227352273622737227382273922740227412274222743227442274522746227472274822749227502275122752227532275422755227562275722758227592276022761227622276322764227652276622767227682276922770227712277222773227742277522776227772277822779227802278122782227832278422785227862278722788227892279022791227922279322794227952279622797227982279922800228012280222803228042280522806228072280822809228102281122812228132281422815228162281722818228192282022821228222282322824228252282622827228282282922830228312283222833228342283522836228372283822839228402284122842228432284422845228462284722848228492285022851228522285322854228552285622857228582285922860228612286222863228642286522866228672286822869228702287122872228732287422875228762287722878228792288022881228822288322884228852288622887228882288922890228912289222893228942289522896228972289822899229002290122902229032290422905229062290722908229092291022911229122291322914229152291622917229182291922920229212292222923229242292522926229272292822929229302293122932229332293422935229362293722938229392294022941229422294322944229452294622947229482294922950229512295222953229542295522956229572295822959229602296122962229632296422965229662296722968229692297022971229722297322974229752297622977229782297922980229812298222983229842298522986229872298822989229902299122992229932299422995229962299722998229992300023001230022300323004230052300623007230082300923010230112301223013230142301523016230172301823019230202302123022230232302423025230262302723028230292303023031230322303323034230352303623037230382303923040230412304223043230442304523046230472304823049230502305123052230532305423055230562305723058230592306023061230622306323064230652306623067230682306923070230712307223073230742307523076230772307823079230802308123082230832308423085230862308723088230892309023091230922309323094230952309623097230982309923100231012310223103231042310523106231072310823109231102311123112231132311423115231162311723118231192312023121231222312323124231252312623127231282312923130231312313223133231342313523136231372313823139231402314123142231432314423145231462314723148231492315023151231522315323154231552315623157231582315923160231612316223163231642316523166231672316823169231702317123172231732317423175231762317723178231792318023181231822318323184231852318623187231882318923190231912319223193231942319523196231972319823199232002320123202232032320423205232062320723208232092321023211232122321323214232152321623217232182321923220232212322223223232242322523226232272322823229232302323123232232332323423235232362323723238232392324023241232422324323244232452324623247232482324923250232512325223253232542325523256232572325823259232602326123262232632326423265232662326723268232692327023271232722327323274232752327623277232782327923280232812328223283232842328523286232872328823289232902329123292232932329423295232962329723298232992330023301233022330323304233052330623307233082330923310233112331223313233142331523316233172331823319233202332123322233232332423325233262332723328233292333023331233322333323334233352333623337233382333923340233412334223343233442334523346233472334823349233502335123352233532335423355233562335723358233592336023361233622336323364233652336623367233682336923370233712337223373233742337523376233772337823379233802338123382233832338423385233862338723388233892339023391233922339323394233952339623397233982339923400234012340223403234042340523406234072340823409234102341123412234132341423415234162341723418234192342023421234222342323424234252342623427234282342923430234312343223433234342343523436234372343823439234402344123442234432344423445234462344723448234492345023451234522345323454234552345623457234582345923460234612346223463234642346523466234672346823469234702347123472234732347423475234762347723478234792348023481234822348323484234852348623487234882348923490234912349223493234942349523496234972349823499235002350123502235032350423505235062350723508235092351023511235122351323514235152351623517235182351923520235212352223523235242352523526235272352823529235302353123532235332353423535235362353723538235392354023541235422354323544235452354623547235482354923550235512355223553235542355523556235572355823559235602356123562235632356423565235662356723568235692357023571235722357323574235752357623577235782357923580235812358223583235842358523586235872358823589235902359123592235932359423595235962359723598235992360023601236022360323604236052360623607236082360923610236112361223613236142361523616236172361823619236202362123622236232362423625236262362723628236292363023631236322363323634236352363623637236382363923640236412364223643236442364523646236472364823649236502365123652236532365423655236562365723658236592366023661236622366323664236652366623667236682366923670236712367223673236742367523676236772367823679236802368123682236832368423685236862368723688236892369023691236922369323694236952369623697236982369923700237012370223703237042370523706237072370823709237102371123712237132371423715237162371723718237192372023721237222372323724237252372623727237282372923730237312373223733237342373523736237372373823739237402374123742237432374423745237462374723748237492375023751237522375323754237552375623757237582375923760237612376223763237642376523766237672376823769237702377123772237732377423775237762377723778237792378023781237822378323784237852378623787237882378923790237912379223793237942379523796237972379823799238002380123802238032380423805238062380723808238092381023811238122381323814238152381623817238182381923820238212382223823238242382523826238272382823829238302383123832238332383423835238362383723838238392384023841238422384323844238452384623847238482384923850238512385223853238542385523856238572385823859238602386123862238632386423865238662386723868238692387023871238722387323874238752387623877238782387923880238812388223883238842388523886238872388823889238902389123892238932389423895238962389723898238992390023901239022390323904239052390623907239082390923910239112391223913239142391523916239172391823919239202392123922239232392423925239262392723928239292393023931239322393323934239352393623937239382393923940239412394223943239442394523946239472394823949239502395123952239532395423955239562395723958239592396023961239622396323964239652396623967239682396923970239712397223973239742397523976239772397823979239802398123982239832398423985239862398723988239892399023991239922399323994239952399623997239982399924000240012400224003240042400524006240072400824009240102401124012240132401424015240162401724018240192402024021240222402324024240252402624027240282402924030240312403224033240342403524036240372403824039240402404124042240432404424045240462404724048240492405024051240522405324054240552405624057240582405924060240612406224063240642406524066240672406824069240702407124072240732407424075240762407724078240792408024081240822408324084240852408624087240882408924090240912409224093240942409524096240972409824099241002410124102241032410424105241062410724108241092411024111241122411324114241152411624117241182411924120241212412224123241242412524126241272412824129241302413124132241332413424135241362413724138241392414024141241422414324144241452414624147241482414924150241512415224153241542415524156241572415824159241602416124162241632416424165241662416724168241692417024171241722417324174241752417624177241782417924180241812418224183241842418524186241872418824189241902419124192241932419424195241962419724198241992420024201242022420324204242052420624207242082420924210242112421224213242142421524216242172421824219242202422124222242232422424225242262422724228242292423024231242322423324234242352423624237242382423924240242412424224243242442424524246242472424824249242502425124252242532425424255242562425724258242592426024261242622426324264242652426624267242682426924270242712427224273242742427524276242772427824279242802428124282242832428424285242862428724288242892429024291242922429324294242952429624297242982429924300243012430224303243042430524306243072430824309243102431124312243132431424315243162431724318243192432024321243222432324324243252432624327243282432924330243312433224333243342433524336243372433824339243402434124342243432434424345243462434724348243492435024351243522435324354243552435624357243582435924360243612436224363243642436524366243672436824369243702437124372243732437424375243762437724378243792438024381243822438324384243852438624387243882438924390243912439224393243942439524396243972439824399244002440124402244032440424405244062440724408244092441024411244122441324414244152441624417244182441924420244212442224423244242442524426244272442824429244302443124432244332443424435244362443724438244392444024441244422444324444244452444624447244482444924450244512445224453244542445524456244572445824459244602446124462244632446424465244662446724468244692447024471244722447324474244752447624477244782447924480244812448224483244842448524486244872448824489244902449124492244932449424495244962449724498244992450024501245022450324504245052450624507245082450924510245112451224513245142451524516245172451824519245202452124522245232452424525245262452724528245292453024531245322453324534245352453624537245382453924540245412454224543245442454524546245472454824549245502455124552245532455424555245562455724558245592456024561245622456324564245652456624567245682456924570245712457224573245742457524576245772457824579245802458124582245832458424585245862458724588245892459024591245922459324594245952459624597245982459924600246012460224603246042460524606246072460824609246102461124612246132461424615246162461724618246192462024621246222462324624246252462624627246282462924630246312463224633246342463524636246372463824639246402464124642246432464424645246462464724648246492465024651246522465324654246552465624657246582465924660246612466224663246642466524666246672466824669246702467124672246732467424675246762467724678246792468024681246822468324684246852468624687246882468924690246912469224693246942469524696246972469824699247002470124702247032470424705247062470724708247092471024711247122471324714247152471624717247182471924720247212472224723247242472524726247272472824729247302473124732247332473424735247362473724738247392474024741247422474324744247452474624747247482474924750247512475224753247542475524756247572475824759247602476124762247632476424765247662476724768247692477024771247722477324774247752477624777247782477924780247812478224783247842478524786247872478824789247902479124792247932479424795247962479724798247992480024801248022480324804248052480624807248082480924810248112481224813248142481524816248172481824819248202482124822248232482424825248262482724828248292483024831248322483324834248352483624837248382483924840248412484224843248442484524846248472484824849248502485124852248532485424855248562485724858248592486024861248622486324864248652486624867248682486924870248712487224873248742487524876248772487824879248802488124882248832488424885248862488724888248892489024891248922489324894248952489624897248982489924900249012490224903249042490524906249072490824909249102491124912249132491424915249162491724918249192492024921249222492324924249252492624927249282492924930249312493224933249342493524936249372493824939249402494124942249432494424945249462494724948249492495024951249522495324954249552495624957249582495924960249612496224963249642496524966249672496824969249702497124972249732497424975249762497724978249792498024981249822498324984249852498624987249882498924990249912499224993249942499524996249972499824999250002500125002250032500425005250062500725008250092501025011250122501325014250152501625017250182501925020250212502225023250242502525026250272502825029250302503125032250332503425035250362503725038250392504025041250422504325044250452504625047250482504925050250512505225053250542505525056250572505825059250602506125062250632506425065250662506725068250692507025071250722507325074250752507625077250782507925080250812508225083250842508525086250872508825089250902509125092250932509425095250962509725098250992510025101251022510325104251052510625107251082510925110251112511225113251142511525116251172511825119251202512125122251232512425125251262512725128251292513025131251322513325134251352513625137251382513925140251412514225143251442514525146251472514825149251502515125152251532515425155251562515725158251592516025161251622516325164251652516625167251682516925170251712517225173251742517525176251772517825179251802518125182251832518425185251862518725188251892519025191251922519325194251952519625197251982519925200252012520225203252042520525206252072520825209252102521125212252132521425215252162521725218252192522025221252222522325224252252522625227252282522925230252312523225233252342523525236252372523825239252402524125242252432524425245252462524725248252492525025251252522525325254252552525625257252582525925260252612526225263252642526525266252672526825269252702527125272252732527425275252762527725278252792528025281252822528325284252852528625287252882528925290252912529225293252942529525296252972529825299253002530125302253032530425305253062530725308253092531025311253122531325314253152531625317253182531925320253212532225323253242532525326253272532825329253302533125332253332533425335253362533725338253392534025341253422534325344253452534625347253482534925350253512535225353253542535525356253572535825359253602536125362253632536425365253662536725368253692537025371253722537325374253752537625377253782537925380253812538225383253842538525386253872538825389253902539125392253932539425395253962539725398253992540025401254022540325404254052540625407254082540925410254112541225413254142541525416254172541825419254202542125422254232542425425254262542725428254292543025431254322543325434254352543625437254382543925440254412544225443254442544525446254472544825449254502545125452254532545425455254562545725458254592546025461254622546325464254652546625467254682546925470254712547225473254742547525476254772547825479254802548125482254832548425485254862548725488254892549025491254922549325494254952549625497254982549925500255012550225503255042550525506255072550825509255102551125512255132551425515255162551725518255192552025521255222552325524255252552625527255282552925530255312553225533255342553525536255372553825539255402554125542255432554425545255462554725548255492555025551255522555325554255552555625557255582555925560255612556225563255642556525566255672556825569255702557125572255732557425575255762557725578255792558025581255822558325584255852558625587255882558925590255912559225593255942559525596255972559825599256002560125602256032560425605256062560725608256092561025611256122561325614256152561625617256182561925620256212562225623256242562525626256272562825629256302563125632256332563425635256362563725638256392564025641256422564325644256452564625647256482564925650256512565225653256542565525656256572565825659256602566125662256632566425665256662566725668256692567025671256722567325674256752567625677256782567925680256812568225683256842568525686256872568825689256902569125692256932569425695256962569725698256992570025701257022570325704257052570625707257082570925710257112571225713257142571525716257172571825719257202572125722257232572425725257262572725728257292573025731257322573325734257352573625737257382573925740257412574225743257442574525746257472574825749257502575125752257532575425755257562575725758257592576025761257622576325764257652576625767257682576925770257712577225773257742577525776257772577825779257802578125782257832578425785257862578725788257892579025791257922579325794257952579625797257982579925800258012580225803258042580525806258072580825809258102581125812258132581425815258162581725818258192582025821258222582325824258252582625827258282582925830258312583225833258342583525836258372583825839258402584125842258432584425845258462584725848258492585025851258522585325854258552585625857258582585925860258612586225863258642586525866258672586825869258702587125872258732587425875258762587725878258792588025881258822588325884258852588625887258882588925890258912589225893258942589525896258972589825899259002590125902259032590425905259062590725908259092591025911259122591325914259152591625917259182591925920259212592225923259242592525926259272592825929259302593125932259332593425935259362593725938259392594025941259422594325944259452594625947259482594925950259512595225953259542595525956259572595825959259602596125962259632596425965259662596725968259692597025971259722597325974259752597625977259782597925980259812598225983259842598525986259872598825989259902599125992259932599425995259962599725998259992600026001260022600326004260052600626007260082600926010260112601226013260142601526016260172601826019260202602126022260232602426025260262602726028260292603026031260322603326034260352603626037260382603926040260412604226043260442604526046260472604826049260502605126052260532605426055260562605726058260592606026061260622606326064260652606626067260682606926070260712607226073260742607526076260772607826079260802608126082260832608426085260862608726088260892609026091260922609326094260952609626097260982609926100261012610226103261042610526106261072610826109261102611126112261132611426115261162611726118261192612026121261222612326124261252612626127261282612926130261312613226133261342613526136261372613826139261402614126142261432614426145261462614726148261492615026151261522615326154261552615626157261582615926160261612616226163261642616526166261672616826169261702617126172261732617426175261762617726178261792618026181261822618326184261852618626187261882618926190261912619226193261942619526196261972619826199262002620126202262032620426205262062620726208262092621026211262122621326214262152621626217262182621926220262212622226223262242622526226262272622826229262302623126232262332623426235262362623726238262392624026241262422624326244262452624626247262482624926250262512625226253262542625526256262572625826259262602626126262262632626426265262662626726268262692627026271262722627326274262752627626277262782627926280262812628226283262842628526286262872628826289262902629126292262932629426295262962629726298262992630026301263022630326304263052630626307263082630926310263112631226313263142631526316263172631826319263202632126322263232632426325263262632726328263292633026331263322633326334263352633626337263382633926340263412634226343263442634526346263472634826349263502635126352263532635426355263562635726358263592636026361263622636326364263652636626367263682636926370263712637226373263742637526376263772637826379263802638126382263832638426385263862638726388263892639026391263922639326394263952639626397263982639926400264012640226403264042640526406264072640826409264102641126412264132641426415264162641726418264192642026421264222642326424264252642626427264282642926430264312643226433264342643526436264372643826439264402644126442264432644426445264462644726448264492645026451264522645326454264552645626457264582645926460264612646226463264642646526466264672646826469264702647126472264732647426475264762647726478264792648026481264822648326484264852648626487264882648926490264912649226493264942649526496264972649826499265002650126502265032650426505265062650726508265092651026511265122651326514265152651626517265182651926520265212652226523265242652526526265272652826529265302653126532265332653426535265362653726538265392654026541265422654326544265452654626547265482654926550265512655226553265542655526556265572655826559265602656126562265632656426565265662656726568265692657026571265722657326574265752657626577265782657926580265812658226583265842658526586265872658826589265902659126592265932659426595265962659726598265992660026601266022660326604266052660626607266082660926610266112661226613266142661526616266172661826619266202662126622266232662426625266262662726628266292663026631266322663326634266352663626637266382663926640266412664226643266442664526646266472664826649266502665126652266532665426655266562665726658266592666026661266622666326664266652666626667266682666926670266712667226673266742667526676266772667826679266802668126682266832668426685266862668726688266892669026691266922669326694266952669626697266982669926700267012670226703267042670526706267072670826709267102671126712267132671426715267162671726718267192672026721267222672326724267252672626727267282672926730267312673226733267342673526736267372673826739267402674126742267432674426745267462674726748267492675026751267522675326754267552675626757267582675926760267612676226763267642676526766267672676826769267702677126772267732677426775267762677726778267792678026781267822678326784267852678626787267882678926790267912679226793267942679526796267972679826799268002680126802268032680426805268062680726808268092681026811268122681326814268152681626817268182681926820268212682226823268242682526826268272682826829268302683126832268332683426835268362683726838268392684026841268422684326844268452684626847268482684926850268512685226853268542685526856268572685826859268602686126862268632686426865268662686726868268692687026871268722687326874268752687626877268782687926880268812688226883268842688526886268872688826889268902689126892268932689426895268962689726898268992690026901269022690326904269052690626907269082690926910269112691226913269142691526916269172691826919269202692126922269232692426925269262692726928269292693026931269322693326934269352693626937269382693926940269412694226943269442694526946269472694826949269502695126952269532695426955269562695726958269592696026961269622696326964269652696626967269682696926970269712697226973269742697526976269772697826979269802698126982269832698426985269862698726988269892699026991269922699326994269952699626997269982699927000270012700227003270042700527006270072700827009270102701127012270132701427015270162701727018270192702027021270222702327024270252702627027270282702927030270312703227033270342703527036270372703827039270402704127042270432704427045270462704727048270492705027051270522705327054270552705627057270582705927060270612706227063270642706527066270672706827069270702707127072270732707427075270762707727078270792708027081270822708327084270852708627087270882708927090270912709227093270942709527096270972709827099271002710127102271032710427105271062710727108271092711027111271122711327114271152711627117271182711927120271212712227123271242712527126271272712827129271302713127132271332713427135271362713727138271392714027141271422714327144271452714627147271482714927150271512715227153271542715527156271572715827159271602716127162271632716427165271662716727168271692717027171271722717327174271752717627177271782717927180271812718227183271842718527186271872718827189271902719127192271932719427195271962719727198271992720027201272022720327204272052720627207272082720927210272112721227213272142721527216272172721827219272202722127222272232722427225272262722727228272292723027231272322723327234272352723627237272382723927240272412724227243272442724527246272472724827249272502725127252272532725427255272562725727258272592726027261272622726327264272652726627267272682726927270272712727227273272742727527276272772727827279272802728127282272832728427285272862728727288272892729027291272922729327294272952729627297272982729927300273012730227303273042730527306273072730827309273102731127312273132731427315273162731727318273192732027321273222732327324273252732627327273282732927330273312733227333273342733527336273372733827339273402734127342273432734427345273462734727348273492735027351273522735327354273552735627357273582735927360273612736227363273642736527366273672736827369273702737127372273732737427375273762737727378273792738027381273822738327384273852738627387273882738927390273912739227393273942739527396273972739827399274002740127402274032740427405274062740727408274092741027411274122741327414274152741627417274182741927420274212742227423274242742527426274272742827429274302743127432274332743427435274362743727438274392744027441274422744327444274452744627447274482744927450274512745227453274542745527456274572745827459274602746127462274632746427465274662746727468274692747027471274722747327474274752747627477274782747927480274812748227483274842748527486274872748827489274902749127492274932749427495274962749727498274992750027501275022750327504275052750627507275082750927510275112751227513275142751527516275172751827519275202752127522275232752427525275262752727528275292753027531275322753327534275352753627537275382753927540275412754227543275442754527546275472754827549275502755127552275532755427555275562755727558275592756027561275622756327564275652756627567275682756927570275712757227573275742757527576275772757827579275802758127582275832758427585275862758727588275892759027591275922759327594275952759627597275982759927600276012760227603276042760527606276072760827609276102761127612276132761427615276162761727618276192762027621276222762327624276252762627627276282762927630276312763227633276342763527636276372763827639276402764127642276432764427645276462764727648276492765027651276522765327654276552765627657276582765927660276612766227663276642766527666276672766827669276702767127672276732767427675276762767727678276792768027681276822768327684276852768627687276882768927690276912769227693276942769527696276972769827699277002770127702277032770427705277062770727708277092771027711277122771327714277152771627717277182771927720277212772227723277242772527726277272772827729277302773127732277332773427735277362773727738277392774027741277422774327744277452774627747277482774927750277512775227753277542775527756277572775827759277602776127762277632776427765277662776727768277692777027771277722777327774277752777627777277782777927780277812778227783277842778527786277872778827789277902779127792277932779427795277962779727798277992780027801278022780327804278052780627807278082780927810278112781227813278142781527816278172781827819278202782127822278232782427825278262782727828278292783027831278322783327834278352783627837278382783927840278412784227843278442784527846278472784827849278502785127852278532785427855278562785727858278592786027861278622786327864278652786627867278682786927870278712787227873278742787527876278772787827879278802788127882278832788427885278862788727888278892789027891278922789327894278952789627897278982789927900279012790227903279042790527906279072790827909279102791127912279132791427915279162791727918279192792027921279222792327924279252792627927279282792927930279312793227933279342793527936279372793827939279402794127942279432794427945279462794727948279492795027951279522795327954279552795627957279582795927960279612796227963279642796527966279672796827969279702797127972279732797427975279762797727978279792798027981279822798327984279852798627987279882798927990279912799227993279942799527996279972799827999280002800128002280032800428005280062800728008280092801028011280122801328014280152801628017280182801928020280212802228023280242802528026280272802828029280302803128032280332803428035280362803728038280392804028041280422804328044280452804628047280482804928050280512805228053280542805528056280572805828059280602806128062280632806428065280662806728068280692807028071280722807328074280752807628077280782807928080280812808228083280842808528086280872808828089280902809128092280932809428095280962809728098280992810028101281022810328104281052810628107281082810928110281112811228113281142811528116281172811828119281202812128122281232812428125281262812728128281292813028131281322813328134281352813628137281382813928140281412814228143281442814528146281472814828149281502815128152281532815428155281562815728158281592816028161281622816328164281652816628167281682816928170281712817228173281742817528176281772817828179281802818128182281832818428185281862818728188281892819028191281922819328194281952819628197281982819928200282012820228203282042820528206282072820828209282102821128212282132821428215282162821728218282192822028221282222822328224282252822628227282282822928230282312823228233282342823528236282372823828239282402824128242282432824428245282462824728248282492825028251282522825328254282552825628257282582825928260282612826228263282642826528266282672826828269282702827128272282732827428275282762827728278282792828028281282822828328284282852828628287282882828928290282912829228293282942829528296282972829828299283002830128302283032830428305283062830728308283092831028311283122831328314283152831628317283182831928320283212832228323283242832528326283272832828329283302833128332283332833428335283362833728338283392834028341283422834328344283452834628347283482834928350283512835228353283542835528356283572835828359283602836128362283632836428365283662836728368283692837028371283722837328374283752837628377283782837928380283812838228383283842838528386283872838828389283902839128392283932839428395283962839728398283992840028401284022840328404284052840628407284082840928410284112841228413284142841528416284172841828419284202842128422284232842428425284262842728428284292843028431284322843328434284352843628437284382843928440284412844228443284442844528446284472844828449284502845128452284532845428455284562845728458284592846028461284622846328464284652846628467284682846928470284712847228473284742847528476284772847828479284802848128482284832848428485284862848728488284892849028491284922849328494284952849628497284982849928500285012850228503285042850528506285072850828509285102851128512285132851428515285162851728518285192852028521285222852328524285252852628527285282852928530285312853228533285342853528536285372853828539285402854128542285432854428545285462854728548285492855028551285522855328554285552855628557285582855928560285612856228563285642856528566285672856828569285702857128572285732857428575285762857728578285792858028581285822858328584285852858628587285882858928590285912859228593285942859528596285972859828599286002860128602286032860428605286062860728608286092861028611286122861328614286152861628617286182861928620286212862228623286242862528626286272862828629286302863128632286332863428635286362863728638286392864028641286422864328644286452864628647286482864928650286512865228653286542865528656286572865828659286602866128662286632866428665286662866728668286692867028671286722867328674286752867628677286782867928680286812868228683286842868528686286872868828689286902869128692286932869428695286962869728698286992870028701287022870328704287052870628707287082870928710287112871228713287142871528716287172871828719287202872128722287232872428725287262872728728287292873028731287322873328734287352873628737287382873928740287412874228743287442874528746287472874828749287502875128752287532875428755287562875728758287592876028761287622876328764287652876628767287682876928770287712877228773287742877528776287772877828779287802878128782287832878428785287862878728788287892879028791287922879328794287952879628797287982879928800288012880228803288042880528806288072880828809288102881128812288132881428815288162881728818288192882028821288222882328824288252882628827288282882928830288312883228833288342883528836288372883828839288402884128842288432884428845288462884728848288492885028851288522885328854288552885628857288582885928860288612886228863288642886528866288672886828869288702887128872288732887428875288762887728878288792888028881288822888328884288852888628887288882888928890288912889228893288942889528896288972889828899289002890128902289032890428905289062890728908289092891028911289122891328914289152891628917289182891928920289212892228923289242892528926289272892828929289302893128932289332893428935289362893728938289392894028941289422894328944289452894628947289482894928950289512895228953289542895528956289572895828959289602896128962289632896428965289662896728968289692897028971289722897328974289752897628977289782897928980289812898228983289842898528986289872898828989289902899128992289932899428995289962899728998289992900029001290022900329004290052900629007290082900929010290112901229013290142901529016290172901829019290202902129022290232902429025290262902729028290292903029031290322903329034290352903629037290382903929040290412904229043290442904529046290472904829049290502905129052290532905429055290562905729058290592906029061290622906329064290652906629067290682906929070290712907229073290742907529076290772907829079290802908129082290832908429085290862908729088290892909029091290922909329094290952909629097290982909929100291012910229103291042910529106291072910829109291102911129112291132911429115291162911729118291192912029121291222912329124291252912629127291282912929130291312913229133291342913529136291372913829139291402914129142291432914429145291462914729148291492915029151291522915329154291552915629157291582915929160291612916229163291642916529166291672916829169291702917129172291732917429175291762917729178291792918029181291822918329184291852918629187291882918929190291912919229193291942919529196291972919829199292002920129202292032920429205292062920729208292092921029211292122921329214292152921629217292182921929220292212922229223292242922529226292272922829229292302923129232292332923429235292362923729238292392924029241292422924329244292452924629247292482924929250292512925229253292542925529256292572925829259292602926129262292632926429265292662926729268292692927029271292722927329274292752927629277292782927929280292812928229283292842928529286292872928829289292902929129292292932929429295292962929729298292992930029301293022930329304293052930629307293082930929310293112931229313293142931529316293172931829319293202932129322293232932429325293262932729328293292933029331293322933329334293352933629337293382933929340293412934229343293442934529346293472934829349293502935129352293532935429355293562935729358293592936029361293622936329364293652936629367293682936929370293712937229373293742937529376293772937829379293802938129382293832938429385293862938729388293892939029391293922939329394293952939629397293982939929400294012940229403294042940529406294072940829409294102941129412294132941429415294162941729418294192942029421294222942329424294252942629427294282942929430294312943229433294342943529436294372943829439294402944129442294432944429445294462944729448294492945029451294522945329454294552945629457294582945929460294612946229463294642946529466294672946829469294702947129472294732947429475294762947729478294792948029481294822948329484294852948629487294882948929490294912949229493294942949529496294972949829499295002950129502295032950429505295062950729508295092951029511295122951329514295152951629517295182951929520295212952229523295242952529526295272952829529295302953129532295332953429535295362953729538295392954029541295422954329544295452954629547295482954929550295512955229553295542955529556295572955829559295602956129562295632956429565295662956729568295692957029571295722957329574295752957629577295782957929580295812958229583295842958529586295872958829589295902959129592295932959429595295962959729598295992960029601296022960329604296052960629607296082960929610296112961229613296142961529616296172961829619296202962129622296232962429625296262962729628296292963029631296322963329634296352963629637296382963929640296412964229643296442964529646296472964829649296502965129652296532965429655296562965729658296592966029661296622966329664296652966629667296682966929670296712967229673296742967529676296772967829679296802968129682296832968429685296862968729688296892969029691296922969329694296952969629697296982969929700297012970229703297042970529706297072970829709297102971129712297132971429715297162971729718297192972029721297222972329724297252972629727297282972929730297312973229733297342973529736297372973829739297402974129742297432974429745297462974729748297492975029751297522975329754297552975629757297582975929760297612976229763297642976529766297672976829769297702977129772297732977429775297762977729778297792978029781297822978329784297852978629787297882978929790297912979229793297942979529796297972979829799298002980129802298032980429805298062980729808298092981029811298122981329814298152981629817298182981929820298212982229823298242982529826298272982829829298302983129832298332983429835298362983729838298392984029841298422984329844298452984629847298482984929850298512985229853298542985529856298572985829859298602986129862298632986429865298662986729868298692987029871298722987329874298752987629877298782987929880298812988229883298842988529886298872988829889298902989129892298932989429895298962989729898298992990029901299022990329904299052990629907299082990929910299112991229913299142991529916299172991829919299202992129922299232992429925299262992729928299292993029931299322993329934299352993629937299382993929940299412994229943299442994529946299472994829949299502995129952299532995429955299562995729958299592996029961299622996329964299652996629967299682996929970299712997229973299742997529976299772997829979299802998129982299832998429985299862998729988299892999029991299922999329994299952999629997299982999930000300013000230003300043000530006300073000830009300103001130012300133001430015300163001730018300193002030021300223002330024300253002630027300283002930030300313003230033300343003530036300373003830039300403004130042300433004430045300463004730048300493005030051300523005330054300553005630057300583005930060300613006230063300643006530066300673006830069300703007130072300733007430075300763007730078300793008030081300823008330084300853008630087300883008930090300913009230093300943009530096300973009830099301003010130102301033010430105301063010730108301093011030111301123011330114301153011630117301183011930120301213012230123301243012530126301273012830129301303013130132301333013430135301363013730138301393014030141301423014330144301453014630147301483014930150301513015230153301543015530156301573015830159301603016130162301633016430165301663016730168301693017030171301723017330174301753017630177301783017930180301813018230183301843018530186301873018830189301903019130192301933019430195301963019730198301993020030201302023020330204302053020630207302083020930210302113021230213302143021530216302173021830219302203022130222302233022430225302263022730228302293023030231302323023330234302353023630237302383023930240302413024230243302443024530246302473024830249302503025130252302533025430255302563025730258302593026030261302623026330264302653026630267302683026930270302713027230273302743027530276302773027830279302803028130282302833028430285302863028730288302893029030291302923029330294302953029630297302983029930300303013030230303303043030530306303073030830309303103031130312303133031430315303163031730318303193032030321303223032330324303253032630327303283032930330303313033230333303343033530336303373033830339303403034130342303433034430345303463034730348303493035030351303523035330354303553035630357303583035930360303613036230363303643036530366303673036830369303703037130372303733037430375303763037730378303793038030381303823038330384303853038630387303883038930390303913039230393303943039530396303973039830399304003040130402304033040430405304063040730408304093041030411304123041330414304153041630417304183041930420304213042230423304243042530426304273042830429304303043130432304333043430435304363043730438304393044030441304423044330444304453044630447304483044930450304513045230453304543045530456304573045830459304603046130462304633046430465304663046730468304693047030471304723047330474304753047630477304783047930480304813048230483304843048530486304873048830489304903049130492304933049430495304963049730498304993050030501305023050330504305053050630507305083050930510305113051230513305143051530516305173051830519305203052130522305233052430525305263052730528305293053030531305323053330534305353053630537305383053930540305413054230543305443054530546305473054830549305503055130552305533055430555305563055730558305593056030561305623056330564305653056630567305683056930570305713057230573305743057530576305773057830579305803058130582305833058430585305863058730588305893059030591305923059330594305953059630597305983059930600306013060230603306043060530606306073060830609306103061130612306133061430615306163061730618306193062030621306223062330624306253062630627306283062930630306313063230633306343063530636306373063830639306403064130642306433064430645306463064730648306493065030651306523065330654306553065630657306583065930660306613066230663306643066530666306673066830669306703067130672306733067430675306763067730678306793068030681306823068330684306853068630687306883068930690306913069230693306943069530696306973069830699307003070130702307033070430705307063070730708307093071030711307123071330714307153071630717307183071930720307213072230723307243072530726307273072830729307303073130732307333073430735307363073730738307393074030741307423074330744307453074630747307483074930750307513075230753307543075530756307573075830759307603076130762307633076430765307663076730768307693077030771307723077330774307753077630777307783077930780307813078230783307843078530786307873078830789307903079130792307933079430795307963079730798307993080030801308023080330804308053080630807308083080930810308113081230813308143081530816308173081830819308203082130822308233082430825308263082730828308293083030831308323083330834308353083630837308383083930840308413084230843308443084530846308473084830849308503085130852308533085430855308563085730858308593086030861308623086330864308653086630867308683086930870308713087230873308743087530876308773087830879308803088130882308833088430885308863088730888308893089030891308923089330894308953089630897308983089930900309013090230903309043090530906309073090830909309103091130912309133091430915309163091730918309193092030921309223092330924309253092630927309283092930930309313093230933309343093530936309373093830939309403094130942309433094430945309463094730948309493095030951309523095330954309553095630957309583095930960309613096230963309643096530966309673096830969309703097130972309733097430975309763097730978309793098030981309823098330984309853098630987309883098930990309913099230993309943099530996309973099830999310003100131002310033100431005310063100731008310093101031011310123101331014310153101631017310183101931020310213102231023310243102531026310273102831029310303103131032310333103431035310363103731038310393104031041310423104331044310453104631047310483104931050310513105231053310543105531056310573105831059310603106131062310633106431065310663106731068310693107031071310723107331074310753107631077310783107931080310813108231083310843108531086310873108831089310903109131092310933109431095310963109731098310993110031101311023110331104311053110631107311083110931110311113111231113311143111531116311173111831119311203112131122311233112431125311263112731128311293113031131311323113331134311353113631137311383113931140311413114231143311443114531146311473114831149311503115131152311533115431155311563115731158311593116031161311623116331164311653116631167311683116931170311713117231173311743117531176311773117831179311803118131182311833118431185311863118731188311893119031191311923119331194311953119631197311983119931200312013120231203312043120531206312073120831209312103121131212312133121431215312163121731218312193122031221312223122331224312253122631227312283122931230312313123231233312343123531236312373123831239312403124131242312433124431245312463124731248312493125031251312523125331254312553125631257312583125931260312613126231263312643126531266312673126831269312703127131272312733127431275312763127731278312793128031281312823128331284312853128631287312883128931290312913129231293312943129531296312973129831299313003130131302313033130431305313063130731308313093131031311313123131331314313153131631317313183131931320313213132231323313243132531326313273132831329313303133131332313333133431335313363133731338313393134031341313423134331344313453134631347313483134931350313513135231353313543135531356313573135831359313603136131362313633136431365313663136731368313693137031371313723137331374313753137631377313783137931380313813138231383313843138531386313873138831389313903139131392313933139431395313963139731398313993140031401314023140331404314053140631407314083140931410314113141231413314143141531416314173141831419314203142131422314233142431425314263142731428314293143031431314323143331434314353143631437314383143931440314413144231443314443144531446314473144831449314503145131452314533145431455314563145731458314593146031461314623146331464314653146631467314683146931470314713147231473314743147531476314773147831479314803148131482314833148431485314863148731488314893149031491314923149331494314953149631497314983149931500315013150231503315043150531506315073150831509315103151131512315133151431515315163151731518315193152031521315223152331524315253152631527315283152931530315313153231533315343153531536315373153831539315403154131542315433154431545315463154731548315493155031551315523155331554315553155631557315583155931560315613156231563315643156531566315673156831569315703157131572315733157431575315763157731578315793158031581315823158331584315853158631587315883158931590315913159231593315943159531596315973159831599316003160131602316033160431605316063160731608316093161031611316123161331614316153161631617316183161931620316213162231623316243162531626316273162831629316303163131632316333163431635316363163731638316393164031641316423164331644316453164631647316483164931650316513165231653316543165531656316573165831659316603166131662316633166431665316663166731668316693167031671316723167331674316753167631677316783167931680316813168231683316843168531686316873168831689316903169131692316933169431695316963169731698316993170031701317023170331704317053170631707317083170931710317113171231713317143171531716317173171831719317203172131722317233172431725317263172731728317293173031731317323173331734317353173631737317383173931740317413174231743317443174531746317473174831749317503175131752317533175431755317563175731758317593176031761317623176331764317653176631767317683176931770317713177231773317743177531776317773177831779317803178131782317833178431785317863178731788317893179031791317923179331794317953179631797317983179931800318013180231803318043180531806318073180831809318103181131812318133181431815318163181731818318193182031821318223182331824318253182631827318283182931830318313183231833318343183531836318373183831839318403184131842318433184431845318463184731848318493185031851318523185331854318553185631857318583185931860318613186231863318643186531866318673186831869318703187131872318733187431875318763187731878318793188031881318823188331884318853188631887318883188931890318913189231893318943189531896318973189831899319003190131902319033190431905319063190731908319093191031911319123191331914319153191631917319183191931920319213192231923319243192531926319273192831929319303193131932319333193431935319363193731938319393194031941319423194331944319453194631947319483194931950319513195231953319543195531956319573195831959319603196131962319633196431965319663196731968319693197031971319723197331974319753197631977319783197931980319813198231983319843198531986319873198831989319903199131992319933199431995319963199731998319993200032001320023200332004320053200632007320083200932010320113201232013320143201532016320173201832019320203202132022320233202432025320263202732028320293203032031320323203332034320353203632037320383203932040320413204232043320443204532046320473204832049320503205132052320533205432055320563205732058320593206032061320623206332064320653206632067320683206932070320713207232073320743207532076320773207832079320803208132082320833208432085320863208732088320893209032091320923209332094320953209632097320983209932100321013210232103321043210532106321073210832109321103211132112321133211432115321163211732118321193212032121321223212332124321253212632127321283212932130321313213232133321343213532136321373213832139321403214132142321433214432145321463214732148321493215032151321523215332154321553215632157321583215932160321613216232163321643216532166321673216832169321703217132172321733217432175321763217732178321793218032181321823218332184321853218632187321883218932190321913219232193321943219532196321973219832199322003220132202322033220432205322063220732208322093221032211322123221332214322153221632217322183221932220322213222232223322243222532226322273222832229322303223132232322333223432235322363223732238322393224032241322423224332244322453224632247322483224932250322513225232253322543225532256322573225832259322603226132262322633226432265322663226732268322693227032271322723227332274322753227632277322783227932280322813228232283322843228532286322873228832289322903229132292322933229432295322963229732298322993230032301323023230332304323053230632307323083230932310323113231232313323143231532316323173231832319323203232132322323233232432325323263232732328323293233032331323323233332334323353233632337323383233932340323413234232343323443234532346323473234832349323503235132352323533235432355323563235732358323593236032361323623236332364323653236632367323683236932370323713237232373323743237532376323773237832379323803238132382323833238432385323863238732388323893239032391323923239332394323953239632397323983239932400324013240232403324043240532406324073240832409324103241132412324133241432415324163241732418324193242032421324223242332424324253242632427324283242932430324313243232433324343243532436324373243832439324403244132442324433244432445324463244732448324493245032451324523245332454324553245632457324583245932460324613246232463324643246532466324673246832469324703247132472324733247432475324763247732478324793248032481324823248332484324853248632487324883248932490324913249232493324943249532496324973249832499325003250132502325033250432505325063250732508325093251032511325123251332514325153251632517325183251932520325213252232523325243252532526325273252832529325303253132532325333253432535325363253732538325393254032541325423254332544325453254632547325483254932550325513255232553325543255532556325573255832559325603256132562325633256432565325663256732568325693257032571325723257332574325753257632577325783257932580325813258232583325843258532586325873258832589325903259132592325933259432595325963259732598325993260032601326023260332604326053260632607326083260932610326113261232613326143261532616326173261832619326203262132622326233262432625326263262732628326293263032631326323263332634326353263632637326383263932640326413264232643326443264532646326473264832649326503265132652326533265432655326563265732658326593266032661326623266332664326653266632667326683266932670326713267232673326743267532676326773267832679326803268132682326833268432685326863268732688326893269032691326923269332694326953269632697326983269932700327013270232703327043270532706327073270832709327103271132712327133271432715327163271732718327193272032721327223272332724327253272632727327283272932730327313273232733327343273532736327373273832739327403274132742327433274432745327463274732748327493275032751327523275332754327553275632757327583275932760327613276232763327643276532766327673276832769327703277132772327733277432775327763277732778327793278032781327823278332784327853278632787327883278932790327913279232793327943279532796327973279832799328003280132802328033280432805328063280732808328093281032811328123281332814328153281632817328183281932820328213282232823328243282532826328273282832829328303283132832328333283432835328363283732838328393284032841328423284332844328453284632847328483284932850328513285232853328543285532856328573285832859328603286132862328633286432865328663286732868328693287032871328723287332874328753287632877328783287932880328813288232883328843288532886328873288832889328903289132892328933289432895328963289732898328993290032901329023290332904329053290632907329083290932910329113291232913329143291532916329173291832919329203292132922329233292432925329263292732928329293293032931329323293332934329353293632937329383293932940329413294232943329443294532946329473294832949329503295132952329533295432955329563295732958329593296032961329623296332964329653296632967329683296932970329713297232973329743297532976329773297832979329803298132982329833298432985329863298732988329893299032991329923299332994329953299632997329983299933000330013300233003330043300533006330073300833009330103301133012330133301433015330163301733018330193302033021330223302333024330253302633027330283302933030330313303233033330343303533036330373303833039330403304133042330433304433045330463304733048330493305033051330523305333054330553305633057330583305933060330613306233063330643306533066330673306833069330703307133072330733307433075330763307733078330793308033081330823308333084330853308633087330883308933090330913309233093330943309533096330973309833099331003310133102331033310433105331063310733108331093311033111331123311333114331153311633117331183311933120331213312233123331243312533126331273312833129331303313133132331333313433135331363313733138331393314033141331423314333144331453314633147331483314933150331513315233153331543315533156331573315833159331603316133162331633316433165331663316733168331693317033171331723317333174331753317633177331783317933180331813318233183331843318533186331873318833189331903319133192331933319433195331963319733198331993320033201332023320333204332053320633207332083320933210332113321233213332143321533216332173321833219332203322133222332233322433225332263322733228332293323033231332323323333234332353323633237332383323933240332413324233243332443324533246332473324833249332503325133252332533325433255332563325733258332593326033261332623326333264332653326633267332683326933270332713327233273332743327533276332773327833279332803328133282332833328433285332863328733288332893329033291332923329333294332953329633297332983329933300333013330233303333043330533306333073330833309333103331133312333133331433315333163331733318333193332033321333223332333324333253332633327333283332933330333313333233333333343333533336333373333833339333403334133342333433334433345333463334733348333493335033351333523335333354333553335633357333583335933360333613336233363333643336533366333673336833369333703337133372333733337433375333763337733378333793338033381333823338333384333853338633387333883338933390333913339233393333943339533396333973339833399334003340133402334033340433405334063340733408334093341033411334123341333414334153341633417334183341933420334213342233423334243342533426334273342833429334303343133432334333343433435334363343733438334393344033441334423344333444334453344633447334483344933450334513345233453334543345533456334573345833459334603346133462334633346433465334663346733468334693347033471334723347333474334753347633477334783347933480334813348233483334843348533486334873348833489334903349133492334933349433495334963349733498334993350033501335023350333504335053350633507335083350933510335113351233513335143351533516335173351833519335203352133522335233352433525335263352733528335293353033531335323353333534335353353633537335383353933540335413354233543335443354533546335473354833549335503355133552335533355433555335563355733558335593356033561335623356333564335653356633567335683356933570335713357233573335743357533576335773357833579335803358133582335833358433585335863358733588335893359033591335923359333594335953359633597335983359933600336013360233603336043360533606336073360833609336103361133612336133361433615336163361733618336193362033621336223362333624336253362633627336283362933630336313363233633336343363533636336373363833639336403364133642336433364433645336463364733648336493365033651336523365333654336553365633657336583365933660336613366233663336643366533666336673366833669336703367133672336733367433675336763367733678336793368033681336823368333684336853368633687336883368933690336913369233693336943369533696336973369833699337003370133702337033370433705337063370733708337093371033711337123371333714337153371633717337183371933720337213372233723337243372533726337273372833729337303373133732337333373433735337363373733738337393374033741337423374333744337453374633747337483374933750337513375233753337543375533756337573375833759337603376133762337633376433765337663376733768337693377033771337723377333774337753377633777337783377933780337813378233783337843378533786337873378833789337903379133792337933379433795337963379733798337993380033801338023380333804338053380633807338083380933810338113381233813338143381533816338173381833819338203382133822338233382433825338263382733828338293383033831338323383333834338353383633837338383383933840338413384233843338443384533846338473384833849338503385133852338533385433855338563385733858338593386033861338623386333864338653386633867338683386933870338713387233873338743387533876338773387833879338803388133882338833388433885338863388733888338893389033891338923389333894338953389633897338983389933900339013390233903339043390533906339073390833909339103391133912339133391433915339163391733918339193392033921339223392333924339253392633927339283392933930339313393233933339343393533936339373393833939339403394133942339433394433945339463394733948339493395033951339523395333954339553395633957339583395933960339613396233963339643396533966339673396833969339703397133972339733397433975339763397733978339793398033981339823398333984339853398633987339883398933990339913399233993339943399533996339973399833999340003400134002340033400434005340063400734008340093401034011340123401334014340153401634017340183401934020340213402234023340243402534026340273402834029340303403134032340333403434035340363403734038340393404034041340423404334044340453404634047340483404934050340513405234053340543405534056340573405834059340603406134062340633406434065340663406734068340693407034071340723407334074340753407634077340783407934080340813408234083340843408534086340873408834089340903409134092340933409434095340963409734098340993410034101341023410334104341053410634107341083410934110341113411234113341143411534116341173411834119341203412134122341233412434125341263412734128341293413034131341323413334134341353413634137341383413934140341413414234143341443414534146341473414834149341503415134152341533415434155341563415734158341593416034161341623416334164341653416634167341683416934170341713417234173341743417534176341773417834179341803418134182341833418434185341863418734188341893419034191341923419334194341953419634197341983419934200342013420234203342043420534206342073420834209342103421134212342133421434215342163421734218342193422034221342223422334224342253422634227342283422934230342313423234233342343423534236342373423834239342403424134242342433424434245342463424734248342493425034251342523425334254342553425634257342583425934260342613426234263342643426534266342673426834269342703427134272342733427434275342763427734278342793428034281342823428334284342853428634287342883428934290342913429234293342943429534296342973429834299343003430134302343033430434305343063430734308343093431034311343123431334314343153431634317343183431934320343213432234323343243432534326343273432834329343303433134332343333433434335343363433734338343393434034341343423434334344343453434634347343483434934350343513435234353343543435534356343573435834359343603436134362343633436434365343663436734368343693437034371343723437334374343753437634377343783437934380343813438234383343843438534386343873438834389343903439134392343933439434395343963439734398343993440034401344023440334404344053440634407344083440934410344113441234413344143441534416344173441834419344203442134422344233442434425344263442734428344293443034431344323443334434344353443634437344383443934440344413444234443344443444534446344473444834449344503445134452344533445434455344563445734458344593446034461344623446334464344653446634467344683446934470344713447234473344743447534476344773447834479344803448134482344833448434485344863448734488344893449034491344923449334494344953449634497344983449934500345013450234503345043450534506345073450834509345103451134512345133451434515345163451734518345193452034521345223452334524345253452634527345283452934530345313453234533345343453534536345373453834539345403454134542345433454434545345463454734548345493455034551345523455334554345553455634557345583455934560345613456234563345643456534566345673456834569345703457134572345733457434575345763457734578345793458034581345823458334584345853458634587345883458934590345913459234593345943459534596345973459834599346003460134602346033460434605346063460734608346093461034611346123461334614346153461634617346183461934620346213462234623346243462534626346273462834629346303463134632346333463434635346363463734638346393464034641346423464334644346453464634647346483464934650346513465234653346543465534656346573465834659346603466134662346633466434665346663466734668346693467034671346723467334674346753467634677346783467934680346813468234683346843468534686346873468834689346903469134692346933469434695346963469734698346993470034701347023470334704347053470634707347083470934710347113471234713347143471534716347173471834719347203472134722347233472434725347263472734728347293473034731347323473334734347353473634737347383473934740347413474234743347443474534746347473474834749347503475134752347533475434755347563475734758347593476034761347623476334764347653476634767347683476934770347713477234773347743477534776347773477834779347803478134782347833478434785347863478734788347893479034791347923479334794347953479634797347983479934800348013480234803348043480534806348073480834809348103481134812348133481434815348163481734818348193482034821348223482334824348253482634827348283482934830348313483234833348343483534836348373483834839348403484134842348433484434845348463484734848348493485034851348523485334854348553485634857348583485934860348613486234863348643486534866348673486834869348703487134872348733487434875348763487734878348793488034881348823488334884348853488634887348883488934890348913489234893348943489534896348973489834899349003490134902349033490434905349063490734908349093491034911349123491334914349153491634917349183491934920349213492234923349243492534926349273492834929349303493134932349333493434935349363493734938349393494034941349423494334944349453494634947349483494934950349513495234953349543495534956349573495834959349603496134962349633496434965349663496734968349693497034971349723497334974349753497634977349783497934980349813498234983349843498534986349873498834989349903499134992349933499434995349963499734998349993500035001350023500335004350053500635007350083500935010350113501235013350143501535016350173501835019350203502135022350233502435025350263502735028350293503035031350323503335034350353503635037350383503935040350413504235043350443504535046350473504835049350503505135052350533505435055350563505735058350593506035061350623506335064350653506635067350683506935070350713507235073350743507535076350773507835079350803508135082350833508435085350863508735088350893509035091350923509335094350953509635097350983509935100351013510235103351043510535106351073510835109351103511135112351133511435115351163511735118351193512035121351223512335124351253512635127351283512935130351313513235133351343513535136351373513835139351403514135142351433514435145351463514735148351493515035151351523515335154351553515635157351583515935160351613516235163351643516535166351673516835169351703517135172351733517435175351763517735178351793518035181351823518335184351853518635187351883518935190351913519235193351943519535196351973519835199352003520135202352033520435205352063520735208352093521035211352123521335214352153521635217352183521935220352213522235223352243522535226352273522835229352303523135232352333523435235352363523735238352393524035241352423524335244352453524635247352483524935250352513525235253352543525535256352573525835259352603526135262352633526435265352663526735268352693527035271352723527335274352753527635277352783527935280352813528235283352843528535286352873528835289352903529135292352933529435295352963529735298352993530035301353023530335304353053530635307353083530935310353113531235313353143531535316353173531835319353203532135322353233532435325353263532735328353293533035331353323533335334353353533635337353383533935340353413534235343353443534535346353473534835349353503535135352353533535435355353563535735358353593536035361353623536335364353653536635367353683536935370353713537235373353743537535376353773537835379353803538135382353833538435385353863538735388353893539035391353923539335394353953539635397353983539935400354013540235403354043540535406354073540835409354103541135412354133541435415354163541735418354193542035421354223542335424354253542635427354283542935430354313543235433354343543535436354373543835439354403544135442354433544435445354463544735448354493545035451354523545335454354553545635457354583545935460354613546235463354643546535466354673546835469354703547135472354733547435475354763547735478354793548035481354823548335484354853548635487354883548935490354913549235493354943549535496354973549835499355003550135502355033550435505355063550735508355093551035511355123551335514355153551635517355183551935520355213552235523355243552535526355273552835529355303553135532355333553435535355363553735538355393554035541355423554335544355453554635547355483554935550355513555235553355543555535556355573555835559355603556135562355633556435565355663556735568355693557035571355723557335574355753557635577355783557935580355813558235583355843558535586355873558835589355903559135592355933559435595355963559735598355993560035601356023560335604356053560635607356083560935610356113561235613356143561535616356173561835619356203562135622356233562435625356263562735628356293563035631356323563335634356353563635637356383563935640356413564235643356443564535646356473564835649356503565135652356533565435655356563565735658356593566035661356623566335664356653566635667356683566935670356713567235673356743567535676356773567835679356803568135682356833568435685356863568735688356893569035691356923569335694356953569635697356983569935700357013570235703357043570535706357073570835709357103571135712357133571435715357163571735718357193572035721357223572335724357253572635727357283572935730357313573235733357343573535736357373573835739357403574135742357433574435745357463574735748357493575035751357523575335754357553575635757357583575935760357613576235763357643576535766357673576835769357703577135772357733577435775357763577735778357793578035781357823578335784357853578635787357883578935790357913579235793357943579535796357973579835799358003580135802358033580435805358063580735808358093581035811358123581335814358153581635817358183581935820358213582235823358243582535826358273582835829358303583135832358333583435835358363583735838358393584035841358423584335844358453584635847358483584935850358513585235853358543585535856358573585835859358603586135862358633586435865358663586735868358693587035871358723587335874358753587635877358783587935880358813588235883358843588535886358873588835889358903589135892358933589435895358963589735898358993590035901359023590335904359053590635907359083590935910359113591235913359143591535916359173591835919359203592135922359233592435925359263592735928359293593035931359323593335934359353593635937359383593935940359413594235943359443594535946359473594835949359503595135952359533595435955359563595735958359593596035961359623596335964359653596635967359683596935970359713597235973359743597535976359773597835979359803598135982359833598435985359863598735988359893599035991359923599335994359953599635997359983599936000360013600236003360043600536006360073600836009360103601136012360133601436015360163601736018360193602036021360223602336024360253602636027360283602936030360313603236033360343603536036360373603836039360403604136042360433604436045360463604736048360493605036051360523605336054360553605636057360583605936060360613606236063360643606536066360673606836069360703607136072360733607436075360763607736078360793608036081360823608336084360853608636087360883608936090360913609236093360943609536096360973609836099361003610136102361033610436105361063610736108361093611036111361123611336114361153611636117361183611936120361213612236123361243612536126361273612836129361303613136132361333613436135361363613736138361393614036141361423614336144361453614636147361483614936150361513615236153361543615536156361573615836159361603616136162361633616436165361663616736168361693617036171361723617336174361753617636177361783617936180361813618236183361843618536186361873618836189361903619136192361933619436195361963619736198361993620036201362023620336204362053620636207362083620936210362113621236213362143621536216362173621836219362203622136222362233622436225362263622736228362293623036231362323623336234362353623636237362383623936240362413624236243362443624536246362473624836249362503625136252362533625436255362563625736258362593626036261362623626336264362653626636267362683626936270362713627236273362743627536276362773627836279362803628136282362833628436285362863628736288362893629036291362923629336294362953629636297362983629936300363013630236303363043630536306363073630836309363103631136312363133631436315363163631736318363193632036321363223632336324363253632636327363283632936330363313633236333363343633536336363373633836339363403634136342363433634436345363463634736348363493635036351363523635336354363553635636357363583635936360363613636236363363643636536366363673636836369363703637136372363733637436375363763637736378363793638036381363823638336384363853638636387363883638936390363913639236393363943639536396363973639836399364003640136402364033640436405364063640736408364093641036411364123641336414364153641636417364183641936420364213642236423364243642536426364273642836429364303643136432364333643436435364363643736438364393644036441364423644336444364453644636447364483644936450364513645236453364543645536456364573645836459364603646136462364633646436465364663646736468364693647036471364723647336474364753647636477364783647936480364813648236483364843648536486364873648836489364903649136492364933649436495364963649736498364993650036501365023650336504365053650636507365083650936510365113651236513365143651536516365173651836519365203652136522365233652436525365263652736528365293653036531365323653336534365353653636537365383653936540365413654236543365443654536546365473654836549365503655136552365533655436555365563655736558365593656036561365623656336564365653656636567365683656936570365713657236573365743657536576365773657836579365803658136582365833658436585365863658736588365893659036591365923659336594365953659636597365983659936600366013660236603366043660536606366073660836609366103661136612366133661436615366163661736618366193662036621366223662336624366253662636627366283662936630366313663236633366343663536636366373663836639366403664136642366433664436645366463664736648366493665036651366523665336654366553665636657366583665936660366613666236663366643666536666366673666836669366703667136672366733667436675366763667736678366793668036681366823668336684366853668636687366883668936690366913669236693366943669536696366973669836699367003670136702367033670436705367063670736708367093671036711367123671336714367153671636717367183671936720367213672236723367243672536726367273672836729367303673136732367333673436735367363673736738367393674036741367423674336744367453674636747367483674936750367513675236753367543675536756367573675836759367603676136762367633676436765367663676736768367693677036771367723677336774367753677636777367783677936780367813678236783367843678536786367873678836789367903679136792367933679436795367963679736798367993680036801368023680336804368053680636807368083680936810368113681236813368143681536816368173681836819368203682136822368233682436825368263682736828368293683036831368323683336834368353683636837368383683936840368413684236843368443684536846368473684836849368503685136852368533685436855368563685736858368593686036861368623686336864368653686636867368683686936870368713687236873368743687536876368773687836879368803688136882368833688436885368863688736888368893689036891368923689336894368953689636897368983689936900369013690236903369043690536906369073690836909369103691136912369133691436915369163691736918369193692036921369223692336924369253692636927369283692936930369313693236933369343693536936369373693836939369403694136942369433694436945369463694736948369493695036951369523695336954369553695636957369583695936960369613696236963369643696536966369673696836969369703697136972369733697436975369763697736978369793698036981369823698336984369853698636987369883698936990369913699236993369943699536996369973699836999370003700137002370033700437005370063700737008370093701037011370123701337014370153701637017370183701937020370213702237023370243702537026370273702837029370303703137032370333703437035370363703737038370393704037041370423704337044370453704637047370483704937050370513705237053370543705537056370573705837059370603706137062370633706437065370663706737068370693707037071370723707337074370753707637077370783707937080370813708237083370843708537086370873708837089370903709137092370933709437095370963709737098370993710037101371023710337104371053710637107371083710937110371113711237113371143711537116371173711837119371203712137122371233712437125371263712737128371293713037131371323713337134371353713637137371383713937140371413714237143371443714537146371473714837149371503715137152371533715437155371563715737158371593716037161371623716337164371653716637167371683716937170371713717237173371743717537176371773717837179371803718137182371833718437185371863718737188371893719037191371923719337194371953719637197371983719937200372013720237203372043720537206372073720837209372103721137212372133721437215372163721737218372193722037221372223722337224372253722637227372283722937230372313723237233372343723537236372373723837239372403724137242372433724437245372463724737248372493725037251372523725337254372553725637257372583725937260372613726237263372643726537266372673726837269372703727137272372733727437275372763727737278372793728037281372823728337284372853728637287372883728937290372913729237293372943729537296372973729837299373003730137302373033730437305373063730737308373093731037311373123731337314373153731637317373183731937320373213732237323373243732537326373273732837329373303733137332373333733437335373363733737338373393734037341373423734337344373453734637347373483734937350373513735237353373543735537356373573735837359373603736137362373633736437365373663736737368373693737037371373723737337374373753737637377373783737937380373813738237383373843738537386373873738837389373903739137392373933739437395373963739737398373993740037401374023740337404374053740637407374083740937410374113741237413374143741537416374173741837419374203742137422374233742437425374263742737428374293743037431374323743337434374353743637437374383743937440374413744237443374443744537446374473744837449374503745137452374533745437455374563745737458374593746037461374623746337464374653746637467374683746937470374713747237473374743747537476374773747837479374803748137482374833748437485374863748737488374893749037491374923749337494374953749637497374983749937500375013750237503375043750537506375073750837509375103751137512375133751437515375163751737518375193752037521375223752337524375253752637527375283752937530375313753237533375343753537536375373753837539375403754137542375433754437545375463754737548375493755037551375523755337554375553755637557375583755937560375613756237563375643756537566375673756837569375703757137572375733757437575375763757737578375793758037581375823758337584375853758637587375883758937590375913759237593375943759537596375973759837599376003760137602376033760437605376063760737608376093761037611376123761337614376153761637617376183761937620376213762237623376243762537626376273762837629376303763137632376333763437635376363763737638376393764037641376423764337644376453764637647376483764937650376513765237653376543765537656376573765837659376603766137662376633766437665376663766737668376693767037671376723767337674376753767637677376783767937680376813768237683376843768537686376873768837689376903769137692376933769437695376963769737698376993770037701377023770337704377053770637707377083770937710377113771237713377143771537716377173771837719377203772137722377233772437725377263772737728377293773037731377323773337734377353773637737377383773937740377413774237743377443774537746377473774837749377503775137752377533775437755377563775737758377593776037761377623776337764377653776637767377683776937770377713777237773377743777537776377773777837779377803778137782377833778437785377863778737788377893779037791377923779337794377953779637797377983779937800378013780237803378043780537806378073780837809378103781137812378133781437815378163781737818378193782037821378223782337824378253782637827378283782937830378313783237833378343783537836378373783837839378403784137842378433784437845378463784737848378493785037851378523785337854378553785637857378583785937860378613786237863378643786537866378673786837869378703787137872378733787437875378763787737878378793788037881378823788337884378853788637887378883788937890378913789237893378943789537896378973789837899379003790137902379033790437905379063790737908379093791037911379123791337914379153791637917379183791937920379213792237923379243792537926379273792837929379303793137932379333793437935379363793737938379393794037941379423794337944379453794637947379483794937950379513795237953379543795537956379573795837959379603796137962379633796437965379663796737968379693797037971379723797337974379753797637977379783797937980379813798237983379843798537986379873798837989379903799137992379933799437995379963799737998379993800038001380023800338004380053800638007380083800938010380113801238013380143801538016380173801838019380203802138022380233802438025380263802738028380293803038031380323803338034380353803638037380383803938040380413804238043380443804538046380473804838049380503805138052380533805438055380563805738058380593806038061380623806338064380653806638067380683806938070380713807238073380743807538076380773807838079380803808138082380833808438085380863808738088380893809038091380923809338094380953809638097380983809938100381013810238103381043810538106381073810838109381103811138112381133811438115381163811738118381193812038121381223812338124381253812638127381283812938130381313813238133381343813538136381373813838139381403814138142381433814438145381463814738148381493815038151381523815338154381553815638157381583815938160381613816238163381643816538166381673816838169381703817138172381733817438175381763817738178381793818038181381823818338184381853818638187381883818938190381913819238193381943819538196381973819838199382003820138202382033820438205382063820738208382093821038211382123821338214382153821638217382183821938220382213822238223382243822538226382273822838229382303823138232382333823438235382363823738238382393824038241382423824338244382453824638247382483824938250382513825238253382543825538256382573825838259382603826138262382633826438265382663826738268382693827038271382723827338274382753827638277382783827938280382813828238283382843828538286382873828838289382903829138292382933829438295382963829738298382993830038301383023830338304383053830638307383083830938310383113831238313383143831538316383173831838319383203832138322383233832438325383263832738328383293833038331383323833338334383353833638337383383833938340383413834238343383443834538346383473834838349383503835138352383533835438355383563835738358383593836038361383623836338364383653836638367383683836938370383713837238373383743837538376383773837838379383803838138382383833838438385383863838738388383893839038391383923839338394383953839638397383983839938400384013840238403384043840538406384073840838409384103841138412384133841438415384163841738418384193842038421384223842338424384253842638427384283842938430384313843238433384343843538436384373843838439384403844138442384433844438445384463844738448384493845038451384523845338454384553845638457384583845938460384613846238463384643846538466384673846838469384703847138472384733847438475384763847738478384793848038481384823848338484384853848638487384883848938490384913849238493384943849538496384973849838499385003850138502385033850438505385063850738508385093851038511385123851338514385153851638517385183851938520385213852238523385243852538526385273852838529385303853138532385333853438535385363853738538385393854038541385423854338544385453854638547385483854938550385513855238553385543855538556385573855838559385603856138562385633856438565385663856738568385693857038571385723857338574385753857638577385783857938580385813858238583385843858538586385873858838589385903859138592385933859438595385963859738598385993860038601386023860338604386053860638607386083860938610386113861238613386143861538616386173861838619386203862138622386233862438625386263862738628386293863038631386323863338634386353863638637386383863938640386413864238643386443864538646386473864838649386503865138652386533865438655386563865738658386593866038661386623866338664386653866638667386683866938670386713867238673386743867538676386773867838679386803868138682386833868438685386863868738688386893869038691386923869338694386953869638697386983869938700387013870238703387043870538706387073870838709387103871138712387133871438715387163871738718387193872038721387223872338724387253872638727387283872938730387313873238733387343873538736387373873838739387403874138742387433874438745387463874738748387493875038751387523875338754387553875638757387583875938760387613876238763387643876538766387673876838769387703877138772387733877438775387763877738778387793878038781387823878338784387853878638787387883878938790387913879238793387943879538796387973879838799388003880138802388033880438805388063880738808388093881038811388123881338814388153881638817388183881938820388213882238823388243882538826388273882838829388303883138832388333883438835388363883738838388393884038841388423884338844388453884638847388483884938850388513885238853388543885538856388573885838859388603886138862388633886438865388663886738868388693887038871388723887338874388753887638877388783887938880388813888238883388843888538886388873888838889388903889138892388933889438895388963889738898388993890038901389023890338904389053890638907389083890938910389113891238913389143891538916389173891838919389203892138922389233892438925389263892738928389293893038931389323893338934389353893638937389383893938940389413894238943389443894538946389473894838949389503895138952389533895438955389563895738958389593896038961389623896338964389653896638967389683896938970389713897238973389743897538976389773897838979389803898138982389833898438985389863898738988389893899038991389923899338994389953899638997389983899939000390013900239003390043900539006390073900839009390103901139012390133901439015390163901739018390193902039021390223902339024390253902639027390283902939030390313903239033390343903539036390373903839039390403904139042390433904439045390463904739048390493905039051390523905339054390553905639057390583905939060390613906239063390643906539066390673906839069390703907139072390733907439075390763907739078390793908039081390823908339084390853908639087390883908939090390913909239093390943909539096390973909839099391003910139102391033910439105391063910739108391093911039111391123911339114391153911639117391183911939120391213912239123391243912539126391273912839129391303913139132391333913439135391363913739138391393914039141391423914339144391453914639147391483914939150391513915239153391543915539156391573915839159391603916139162391633916439165391663916739168391693917039171391723917339174391753917639177391783917939180391813918239183391843918539186391873918839189391903919139192391933919439195391963919739198391993920039201392023920339204392053920639207392083920939210392113921239213392143921539216392173921839219392203922139222392233922439225392263922739228392293923039231392323923339234392353923639237392383923939240392413924239243392443924539246392473924839249392503925139252392533925439255392563925739258392593926039261392623926339264392653926639267392683926939270392713927239273392743927539276392773927839279392803928139282392833928439285392863928739288392893929039291392923929339294392953929639297392983929939300393013930239303393043930539306393073930839309393103931139312393133931439315393163931739318393193932039321393223932339324393253932639327393283932939330393313933239333393343933539336393373933839339393403934139342393433934439345393463934739348393493935039351393523935339354393553935639357393583935939360393613936239363393643936539366393673936839369393703937139372393733937439375393763937739378393793938039381393823938339384393853938639387393883938939390393913939239393393943939539396393973939839399394003940139402394033940439405394063940739408394093941039411394123941339414394153941639417394183941939420394213942239423394243942539426394273942839429394303943139432394333943439435394363943739438394393944039441394423944339444394453944639447394483944939450394513945239453394543945539456394573945839459394603946139462394633946439465394663946739468394693947039471394723947339474394753947639477394783947939480394813948239483394843948539486394873948839489394903949139492394933949439495394963949739498394993950039501395023950339504395053950639507395083950939510395113951239513395143951539516395173951839519395203952139522395233952439525395263952739528395293953039531395323953339534395353953639537395383953939540395413954239543395443954539546395473954839549395503955139552395533955439555395563955739558395593956039561395623956339564395653956639567395683956939570395713957239573395743957539576395773957839579395803958139582395833958439585395863958739588395893959039591395923959339594395953959639597395983959939600396013960239603396043960539606396073960839609396103961139612396133961439615396163961739618396193962039621396223962339624396253962639627396283962939630396313963239633396343963539636396373963839639396403964139642396433964439645396463964739648396493965039651396523965339654396553965639657396583965939660396613966239663396643966539666396673966839669396703967139672396733967439675396763967739678396793968039681396823968339684396853968639687396883968939690396913969239693396943969539696396973969839699397003970139702397033970439705397063970739708397093971039711397123971339714397153971639717397183971939720397213972239723397243972539726397273972839729397303973139732397333973439735397363973739738397393974039741397423974339744397453974639747397483974939750397513975239753397543975539756397573975839759397603976139762397633976439765397663976739768397693977039771397723977339774397753977639777397783977939780397813978239783397843978539786397873978839789397903979139792397933979439795397963979739798397993980039801398023980339804398053980639807398083980939810398113981239813398143981539816398173981839819398203982139822398233982439825398263982739828398293983039831398323983339834398353983639837398383983939840398413984239843398443984539846398473984839849398503985139852398533985439855398563985739858398593986039861398623986339864398653986639867398683986939870398713987239873398743987539876398773987839879398803988139882398833988439885398863988739888398893989039891398923989339894398953989639897398983989939900399013990239903399043990539906399073990839909399103991139912399133991439915399163991739918399193992039921399223992339924399253992639927399283992939930399313993239933399343993539936399373993839939399403994139942399433994439945399463994739948399493995039951399523995339954399553995639957399583995939960399613996239963399643996539966399673996839969399703997139972399733997439975399763997739978399793998039981399823998339984399853998639987399883998939990399913999239993399943999539996399973999839999400004000140002400034000440005400064000740008400094001040011400124001340014400154001640017400184001940020400214002240023400244002540026400274002840029400304003140032400334003440035400364003740038400394004040041400424004340044400454004640047400484004940050400514005240053400544005540056400574005840059400604006140062400634006440065400664006740068400694007040071400724007340074400754007640077400784007940080400814008240083400844008540086400874008840089400904009140092400934009440095400964009740098400994010040101401024010340104401054010640107401084010940110401114011240113401144011540116401174011840119401204012140122401234012440125401264012740128401294013040131401324013340134401354013640137401384013940140401414014240143401444014540146401474014840149401504015140152401534015440155401564015740158401594016040161401624016340164401654016640167401684016940170401714017240173401744017540176401774017840179401804018140182401834018440185401864018740188401894019040191401924019340194401954019640197401984019940200402014020240203402044020540206402074020840209402104021140212402134021440215402164021740218402194022040221402224022340224402254022640227402284022940230402314023240233402344023540236402374023840239402404024140242402434024440245402464024740248402494025040251402524025340254402554025640257402584025940260402614026240263402644026540266402674026840269402704027140272402734027440275402764027740278402794028040281402824028340284402854028640287402884028940290402914029240293402944029540296402974029840299403004030140302403034030440305403064030740308403094031040311403124031340314403154031640317403184031940320403214032240323403244032540326403274032840329403304033140332403334033440335403364033740338403394034040341403424034340344403454034640347403484034940350403514035240353403544035540356403574035840359403604036140362403634036440365403664036740368403694037040371403724037340374403754037640377403784037940380403814038240383403844038540386403874038840389403904039140392403934039440395403964039740398403994040040401404024040340404404054040640407404084040940410404114041240413404144041540416404174041840419404204042140422404234042440425404264042740428404294043040431404324043340434404354043640437404384043940440404414044240443404444044540446404474044840449404504045140452404534045440455404564045740458404594046040461404624046340464404654046640467404684046940470404714047240473404744047540476404774047840479404804048140482404834048440485404864048740488404894049040491404924049340494404954049640497404984049940500405014050240503405044050540506405074050840509405104051140512405134051440515405164051740518405194052040521405224052340524405254052640527405284052940530405314053240533405344053540536405374053840539405404054140542405434054440545405464054740548405494055040551405524055340554405554055640557405584055940560405614056240563405644056540566405674056840569405704057140572405734057440575405764057740578405794058040581405824058340584405854058640587405884058940590405914059240593405944059540596405974059840599406004060140602406034060440605406064060740608406094061040611406124061340614406154061640617406184061940620406214062240623406244062540626406274062840629406304063140632406334063440635406364063740638406394064040641406424064340644406454064640647406484064940650406514065240653406544065540656406574065840659406604066140662406634066440665406664066740668406694067040671406724067340674406754067640677406784067940680406814068240683406844068540686406874068840689406904069140692406934069440695406964069740698406994070040701407024070340704407054070640707407084070940710407114071240713407144071540716407174071840719407204072140722407234072440725407264072740728407294073040731407324073340734407354073640737407384073940740407414074240743407444074540746407474074840749407504075140752407534075440755407564075740758407594076040761407624076340764407654076640767407684076940770407714077240773407744077540776407774077840779407804078140782407834078440785407864078740788407894079040791407924079340794407954079640797407984079940800408014080240803408044080540806408074080840809408104081140812408134081440815408164081740818408194082040821408224082340824408254082640827408284082940830408314083240833408344083540836408374083840839408404084140842408434084440845408464084740848408494085040851408524085340854408554085640857408584085940860408614086240863408644086540866408674086840869408704087140872408734087440875408764087740878408794088040881408824088340884408854088640887408884088940890408914089240893408944089540896408974089840899409004090140902409034090440905409064090740908409094091040911409124091340914409154091640917409184091940920409214092240923409244092540926409274092840929409304093140932409334093440935409364093740938409394094040941409424094340944409454094640947409484094940950409514095240953409544095540956409574095840959409604096140962409634096440965409664096740968409694097040971409724097340974409754097640977409784097940980409814098240983409844098540986409874098840989409904099140992409934099440995409964099740998409994100041001410024100341004410054100641007410084100941010410114101241013410144101541016410174101841019410204102141022410234102441025410264102741028410294103041031410324103341034410354103641037410384103941040410414104241043410444104541046410474104841049410504105141052410534105441055410564105741058410594106041061410624106341064410654106641067410684106941070410714107241073410744107541076410774107841079410804108141082410834108441085410864108741088410894109041091410924109341094410954109641097410984109941100411014110241103411044110541106411074110841109411104111141112411134111441115411164111741118411194112041121411224112341124411254112641127411284112941130411314113241133411344113541136411374113841139411404114141142411434114441145411464114741148411494115041151411524115341154411554115641157411584115941160411614116241163411644116541166411674116841169411704117141172411734117441175411764117741178411794118041181411824118341184411854118641187411884118941190411914119241193411944119541196411974119841199412004120141202412034120441205412064120741208412094121041211412124121341214412154121641217412184121941220412214122241223412244122541226412274122841229412304123141232412334123441235412364123741238412394124041241412424124341244412454124641247412484124941250412514125241253412544125541256412574125841259412604126141262412634126441265412664126741268412694127041271412724127341274412754127641277412784127941280412814128241283412844128541286412874128841289412904129141292412934129441295412964129741298412994130041301413024130341304413054130641307413084130941310413114131241313413144131541316413174131841319413204132141322413234132441325413264132741328413294133041331413324133341334413354133641337413384133941340413414134241343413444134541346413474134841349413504135141352413534135441355413564135741358413594136041361413624136341364413654136641367413684136941370413714137241373413744137541376413774137841379413804138141382413834138441385413864138741388413894139041391413924139341394413954139641397413984139941400414014140241403414044140541406414074140841409414104141141412414134141441415414164141741418414194142041421414224142341424414254142641427414284142941430414314143241433414344143541436414374143841439414404144141442414434144441445414464144741448414494145041451414524145341454414554145641457414584145941460414614146241463414644146541466414674146841469414704147141472414734147441475414764147741478414794148041481414824148341484414854148641487414884148941490414914149241493414944149541496414974149841499415004150141502415034150441505415064150741508415094151041511415124151341514415154151641517415184151941520415214152241523415244152541526415274152841529415304153141532415334153441535415364153741538415394154041541415424154341544415454154641547415484154941550415514155241553415544155541556415574155841559415604156141562415634156441565415664156741568415694157041571415724157341574415754157641577415784157941580415814158241583415844158541586415874158841589415904159141592415934159441595415964159741598415994160041601416024160341604416054160641607416084160941610416114161241613416144161541616416174161841619416204162141622416234162441625416264162741628416294163041631416324163341634416354163641637416384163941640416414164241643416444164541646416474164841649416504165141652416534165441655416564165741658416594166041661416624166341664416654166641667416684166941670416714167241673416744167541676416774167841679416804168141682416834168441685416864168741688416894169041691416924169341694416954169641697416984169941700417014170241703417044170541706417074170841709417104171141712417134171441715417164171741718417194172041721417224172341724417254172641727417284172941730417314173241733417344173541736417374173841739417404174141742417434174441745417464174741748417494175041751417524175341754417554175641757417584175941760417614176241763417644176541766417674176841769417704177141772417734177441775417764177741778417794178041781417824178341784417854178641787417884178941790417914179241793417944179541796417974179841799418004180141802418034180441805418064180741808418094181041811418124181341814418154181641817418184181941820418214182241823418244182541826418274182841829418304183141832418334183441835418364183741838418394184041841418424184341844418454184641847418484184941850418514185241853418544185541856418574185841859418604186141862418634186441865418664186741868418694187041871418724187341874418754187641877418784187941880418814188241883418844188541886418874188841889418904189141892418934189441895418964189741898418994190041901419024190341904419054190641907419084190941910419114191241913419144191541916419174191841919419204192141922419234192441925419264192741928419294193041931419324193341934419354193641937419384193941940419414194241943419444194541946419474194841949419504195141952419534195441955419564195741958419594196041961419624196341964419654196641967419684196941970419714197241973419744197541976419774197841979419804198141982419834198441985419864198741988419894199041991419924199341994419954199641997419984199942000420014200242003420044200542006420074200842009420104201142012420134201442015420164201742018420194202042021420224202342024420254202642027420284202942030420314203242033420344203542036420374203842039420404204142042420434204442045420464204742048420494205042051420524205342054420554205642057420584205942060420614206242063420644206542066420674206842069420704207142072420734207442075420764207742078420794208042081420824208342084420854208642087420884208942090420914209242093420944209542096420974209842099421004210142102421034210442105421064210742108421094211042111421124211342114421154211642117421184211942120421214212242123421244212542126421274212842129421304213142132421334213442135421364213742138421394214042141421424214342144421454214642147421484214942150421514215242153421544215542156421574215842159421604216142162421634216442165421664216742168421694217042171421724217342174421754217642177421784217942180421814218242183421844218542186421874218842189421904219142192421934219442195421964219742198421994220042201422024220342204422054220642207422084220942210422114221242213422144221542216422174221842219422204222142222422234222442225422264222742228422294223042231422324223342234422354223642237422384223942240422414224242243422444224542246422474224842249422504225142252422534225442255422564225742258422594226042261422624226342264422654226642267422684226942270422714227242273422744227542276422774227842279422804228142282422834228442285422864228742288422894229042291422924229342294422954229642297422984229942300423014230242303423044230542306423074230842309423104231142312423134231442315423164231742318423194232042321423224232342324423254232642327423284232942330423314233242333423344233542336423374233842339423404234142342423434234442345423464234742348423494235042351423524235342354423554235642357423584235942360423614236242363423644236542366423674236842369423704237142372423734237442375423764237742378423794238042381423824238342384423854238642387423884238942390423914239242393423944239542396423974239842399424004240142402424034240442405424064240742408424094241042411424124241342414424154241642417424184241942420424214242242423424244242542426424274242842429424304243142432424334243442435424364243742438424394244042441424424244342444424454244642447424484244942450424514245242453424544245542456424574245842459424604246142462424634246442465424664246742468424694247042471424724247342474424754247642477424784247942480424814248242483424844248542486424874248842489424904249142492424934249442495424964249742498424994250042501425024250342504425054250642507425084250942510425114251242513425144251542516425174251842519425204252142522425234252442525425264252742528425294253042531425324253342534425354253642537425384253942540425414254242543425444254542546425474254842549425504255142552425534255442555425564255742558425594256042561425624256342564425654256642567425684256942570425714257242573425744257542576425774257842579425804258142582425834258442585425864258742588425894259042591425924259342594425954259642597425984259942600426014260242603426044260542606426074260842609426104261142612426134261442615426164261742618426194262042621426224262342624426254262642627426284262942630426314263242633426344263542636426374263842639426404264142642426434264442645426464264742648426494265042651426524265342654426554265642657426584265942660426614266242663426644266542666426674266842669426704267142672426734267442675426764267742678426794268042681426824268342684426854268642687426884268942690426914269242693426944269542696426974269842699427004270142702427034270442705427064270742708427094271042711427124271342714427154271642717427184271942720427214272242723427244272542726427274272842729427304273142732427334273442735427364273742738427394274042741427424274342744427454274642747427484274942750427514275242753427544275542756427574275842759427604276142762427634276442765427664276742768427694277042771427724277342774427754277642777427784277942780427814278242783427844278542786427874278842789427904279142792427934279442795427964279742798427994280042801428024280342804428054280642807428084280942810428114281242813428144281542816428174281842819428204282142822428234282442825428264282742828428294283042831428324283342834428354283642837428384283942840428414284242843428444284542846428474284842849428504285142852428534285442855428564285742858428594286042861428624286342864428654286642867428684286942870428714287242873428744287542876428774287842879428804288142882428834288442885428864288742888428894289042891428924289342894428954289642897428984289942900429014290242903429044290542906429074290842909429104291142912429134291442915429164291742918429194292042921429224292342924429254292642927429284292942930429314293242933429344293542936429374293842939429404294142942429434294442945429464294742948429494295042951429524295342954429554295642957429584295942960429614296242963429644296542966429674296842969429704297142972429734297442975429764297742978429794298042981429824298342984429854298642987429884298942990429914299242993429944299542996429974299842999430004300143002430034300443005430064300743008430094301043011430124301343014430154301643017430184301943020430214302243023430244302543026430274302843029430304303143032430334303443035430364303743038430394304043041430424304343044430454304643047430484304943050430514305243053430544305543056430574305843059430604306143062430634306443065430664306743068430694307043071430724307343074430754307643077430784307943080430814308243083430844308543086430874308843089430904309143092430934309443095430964309743098430994310043101431024310343104431054310643107431084310943110431114311243113431144311543116431174311843119431204312143122431234312443125431264312743128431294313043131431324313343134431354313643137431384313943140431414314243143431444314543146431474314843149431504315143152431534315443155431564315743158431594316043161431624316343164431654316643167431684316943170431714317243173431744317543176431774317843179431804318143182431834318443185431864318743188431894319043191431924319343194431954319643197431984319943200432014320243203432044320543206432074320843209432104321143212432134321443215432164321743218432194322043221432224322343224432254322643227432284322943230432314323243233432344323543236432374323843239432404324143242432434324443245432464324743248432494325043251432524325343254432554325643257432584325943260432614326243263432644326543266432674326843269432704327143272432734327443275432764327743278432794328043281432824328343284432854328643287432884328943290432914329243293432944329543296432974329843299433004330143302433034330443305433064330743308433094331043311433124331343314433154331643317433184331943320433214332243323433244332543326433274332843329433304333143332433334333443335433364333743338433394334043341433424334343344433454334643347433484334943350433514335243353433544335543356433574335843359433604336143362433634336443365433664336743368433694337043371433724337343374433754337643377433784337943380433814338243383433844338543386433874338843389433904339143392433934339443395433964339743398433994340043401434024340343404434054340643407434084340943410434114341243413434144341543416434174341843419434204342143422434234342443425434264342743428434294343043431434324343343434434354343643437434384343943440434414344243443434444344543446434474344843449434504345143452434534345443455434564345743458434594346043461434624346343464434654346643467434684346943470434714347243473434744347543476434774347843479434804348143482434834348443485434864348743488434894349043491434924349343494434954349643497434984349943500435014350243503435044350543506435074350843509435104351143512435134351443515435164351743518435194352043521435224352343524435254352643527435284352943530435314353243533435344353543536435374353843539435404354143542435434354443545435464354743548435494355043551435524355343554435554355643557435584355943560435614356243563435644356543566435674356843569435704357143572435734357443575435764357743578435794358043581435824358343584435854358643587435884358943590435914359243593435944359543596435974359843599436004360143602436034360443605436064360743608436094361043611436124361343614436154361643617436184361943620436214362243623436244362543626436274362843629436304363143632436334363443635436364363743638436394364043641436424364343644436454364643647436484364943650436514365243653436544365543656436574365843659436604366143662436634366443665436664366743668436694367043671436724367343674436754367643677436784367943680436814368243683436844368543686436874368843689436904369143692436934369443695436964369743698436994370043701437024370343704437054370643707437084370943710437114371243713437144371543716437174371843719437204372143722437234372443725437264372743728437294373043731437324373343734437354373643737437384373943740437414374243743437444374543746437474374843749437504375143752437534375443755437564375743758437594376043761437624376343764437654376643767437684376943770437714377243773437744377543776437774377843779437804378143782437834378443785437864378743788437894379043791437924379343794437954379643797437984379943800438014380243803438044380543806438074380843809438104381143812438134381443815438164381743818438194382043821438224382343824438254382643827438284382943830438314383243833438344383543836438374383843839438404384143842438434384443845438464384743848438494385043851438524385343854438554385643857438584385943860438614386243863438644386543866438674386843869438704387143872438734387443875438764387743878438794388043881438824388343884438854388643887438884388943890438914389243893438944389543896438974389843899439004390143902439034390443905439064390743908439094391043911439124391343914439154391643917439184391943920439214392243923439244392543926439274392843929439304393143932439334393443935439364393743938439394394043941439424394343944439454394643947439484394943950439514395243953439544395543956439574395843959439604396143962439634396443965439664396743968439694397043971439724397343974439754397643977439784397943980439814398243983439844398543986439874398843989439904399143992439934399443995439964399743998439994400044001440024400344004440054400644007440084400944010440114401244013440144401544016440174401844019440204402144022440234402444025440264402744028440294403044031440324403344034440354403644037440384403944040440414404244043440444404544046440474404844049440504405144052440534405444055440564405744058440594406044061440624406344064440654406644067440684406944070440714407244073440744407544076440774407844079440804408144082440834408444085440864408744088440894409044091440924409344094440954409644097440984409944100441014410244103441044410544106441074410844109441104411144112441134411444115441164411744118441194412044121441224412344124441254412644127441284412944130441314413244133441344413544136441374413844139441404414144142441434414444145441464414744148441494415044151441524415344154441554415644157441584415944160441614416244163441644416544166441674416844169441704417144172441734417444175441764417744178441794418044181441824418344184441854418644187441884418944190441914419244193441944419544196441974419844199442004420144202442034420444205442064420744208442094421044211442124421344214442154421644217442184421944220442214422244223442244422544226442274422844229442304423144232442334423444235442364423744238442394424044241442424424344244442454424644247442484424944250442514425244253442544425544256442574425844259442604426144262442634426444265442664426744268442694427044271442724427344274442754427644277442784427944280442814428244283442844428544286442874428844289442904429144292442934429444295442964429744298442994430044301443024430344304443054430644307443084430944310443114431244313443144431544316443174431844319443204432144322443234432444325443264432744328443294433044331443324433344334443354433644337443384433944340443414434244343443444434544346443474434844349443504435144352443534435444355443564435744358443594436044361443624436344364443654436644367443684436944370443714437244373443744437544376443774437844379443804438144382443834438444385443864438744388443894439044391443924439344394443954439644397443984439944400444014440244403444044440544406444074440844409444104441144412444134441444415444164441744418444194442044421444224442344424444254442644427444284442944430444314443244433444344443544436444374443844439444404444144442444434444444445444464444744448444494445044451444524445344454444554445644457444584445944460444614446244463444644446544466444674446844469444704447144472444734447444475444764447744478444794448044481444824448344484444854448644487444884448944490444914449244493444944449544496444974449844499445004450144502445034450444505445064450744508445094451044511445124451344514445154451644517445184451944520445214452244523445244452544526445274452844529445304453144532445334453444535445364453744538445394454044541445424454344544445454454644547445484454944550445514455244553445544455544556445574455844559445604456144562445634456444565445664456744568445694457044571445724457344574445754457644577445784457944580445814458244583445844458544586445874458844589445904459144592445934459444595445964459744598445994460044601446024460344604446054460644607446084460944610446114461244613446144461544616446174461844619446204462144622446234462444625446264462744628446294463044631446324463344634446354463644637446384463944640446414464244643446444464544646446474464844649446504465144652446534465444655446564465744658446594466044661446624466344664446654466644667446684466944670446714467244673446744467544676446774467844679446804468144682446834468444685446864468744688446894469044691446924469344694446954469644697446984469944700447014470244703447044470544706447074470844709447104471144712447134471444715447164471744718447194472044721447224472344724447254472644727447284472944730447314473244733447344473544736447374473844739447404474144742447434474444745447464474744748447494475044751447524475344754447554475644757447584475944760447614476244763447644476544766447674476844769447704477144772447734477444775447764477744778447794478044781447824478344784447854478644787447884478944790447914479244793447944479544796447974479844799448004480144802448034480444805448064480744808448094481044811448124481344814448154481644817448184481944820448214482244823448244482544826448274482844829448304483144832448334483444835448364483744838448394484044841448424484344844448454484644847448484484944850448514485244853448544485544856448574485844859448604486144862448634486444865448664486744868448694487044871448724487344874448754487644877448784487944880448814488244883448844488544886448874488844889448904489144892448934489444895448964489744898448994490044901449024490344904449054490644907449084490944910449114491244913449144491544916449174491844919449204492144922449234492444925449264492744928449294493044931449324493344934449354493644937449384493944940449414494244943449444494544946449474494844949449504495144952449534495444955449564495744958449594496044961449624496344964449654496644967449684496944970449714497244973449744497544976449774497844979449804498144982449834498444985449864498744988449894499044991449924499344994449954499644997449984499945000450014500245003450044500545006450074500845009450104501145012450134501445015450164501745018450194502045021450224502345024450254502645027450284502945030450314503245033450344503545036450374503845039450404504145042450434504445045450464504745048450494505045051450524505345054450554505645057450584505945060450614506245063450644506545066450674506845069450704507145072450734507445075450764507745078450794508045081450824508345084450854508645087450884508945090450914509245093450944509545096450974509845099451004510145102451034510445105451064510745108451094511045111451124511345114451154511645117451184511945120451214512245123451244512545126451274512845129451304513145132451334513445135451364513745138451394514045141451424514345144451454514645147451484514945150451514515245153451544515545156451574515845159451604516145162451634516445165451664516745168451694517045171451724517345174451754517645177451784517945180451814518245183451844518545186451874518845189451904519145192451934519445195451964519745198451994520045201452024520345204452054520645207452084520945210452114521245213452144521545216452174521845219452204522145222452234522445225452264522745228452294523045231452324523345234452354523645237452384523945240452414524245243452444524545246452474524845249452504525145252452534525445255452564525745258452594526045261452624526345264452654526645267452684526945270452714527245273452744527545276452774527845279452804528145282452834528445285452864528745288452894529045291452924529345294452954529645297452984529945300453014530245303453044530545306453074530845309453104531145312453134531445315453164531745318453194532045321453224532345324453254532645327453284532945330453314533245333453344533545336453374533845339453404534145342453434534445345453464534745348453494535045351453524535345354453554535645357453584535945360453614536245363453644536545366453674536845369453704537145372453734537445375453764537745378453794538045381453824538345384453854538645387453884538945390453914539245393453944539545396453974539845399454004540145402454034540445405454064540745408454094541045411454124541345414454154541645417454184541945420454214542245423454244542545426454274542845429454304543145432454334543445435454364543745438454394544045441454424544345444454454544645447454484544945450454514545245453454544545545456454574545845459454604546145462454634546445465454664546745468454694547045471454724547345474454754547645477454784547945480454814548245483454844548545486454874548845489454904549145492454934549445495454964549745498454994550045501455024550345504455054550645507455084550945510455114551245513455144551545516455174551845519455204552145522455234552445525455264552745528455294553045531455324553345534455354553645537455384553945540455414554245543455444554545546455474554845549455504555145552455534555445555455564555745558455594556045561455624556345564455654556645567455684556945570455714557245573455744557545576455774557845579455804558145582455834558445585455864558745588455894559045591455924559345594455954559645597455984559945600456014560245603456044560545606456074560845609456104561145612456134561445615456164561745618456194562045621456224562345624456254562645627456284562945630456314563245633456344563545636456374563845639456404564145642456434564445645456464564745648456494565045651456524565345654456554565645657456584565945660456614566245663456644566545666456674566845669456704567145672456734567445675456764567745678456794568045681456824568345684456854568645687456884568945690456914569245693456944569545696456974569845699457004570145702457034570445705457064570745708457094571045711457124571345714457154571645717457184571945720457214572245723457244572545726457274572845729457304573145732457334573445735457364573745738457394574045741457424574345744457454574645747457484574945750457514575245753457544575545756457574575845759457604576145762457634576445765457664576745768457694577045771457724577345774457754577645777457784577945780457814578245783457844578545786457874578845789457904579145792457934579445795457964579745798457994580045801458024580345804458054580645807458084580945810458114581245813458144581545816458174581845819458204582145822458234582445825458264582745828458294583045831458324583345834458354583645837458384583945840458414584245843458444584545846458474584845849458504585145852458534585445855458564585745858458594586045861458624586345864458654586645867458684586945870458714587245873458744587545876458774587845879458804588145882458834588445885458864588745888458894589045891458924589345894458954589645897458984589945900459014590245903459044590545906459074590845909459104591145912459134591445915459164591745918459194592045921459224592345924459254592645927459284592945930459314593245933459344593545936459374593845939459404594145942459434594445945459464594745948459494595045951459524595345954459554595645957459584595945960459614596245963459644596545966459674596845969459704597145972459734597445975459764597745978459794598045981459824598345984459854598645987459884598945990459914599245993459944599545996459974599845999460004600146002460034600446005460064600746008460094601046011460124601346014460154601646017460184601946020460214602246023460244602546026460274602846029460304603146032460334603446035460364603746038460394604046041460424604346044460454604646047460484604946050460514605246053460544605546056460574605846059460604606146062460634606446065460664606746068460694607046071460724607346074460754607646077460784607946080460814608246083460844608546086460874608846089460904609146092460934609446095460964609746098460994610046101461024610346104461054610646107461084610946110461114611246113461144611546116461174611846119461204612146122461234612446125461264612746128461294613046131461324613346134461354613646137461384613946140461414614246143461444614546146461474614846149461504615146152461534615446155461564615746158461594616046161461624616346164461654616646167461684616946170461714617246173461744617546176461774617846179461804618146182461834618446185461864618746188461894619046191461924619346194461954619646197461984619946200462014620246203462044620546206462074620846209462104621146212462134621446215462164621746218462194622046221462224622346224462254622646227462284622946230462314623246233462344623546236462374623846239462404624146242462434624446245462464624746248462494625046251462524625346254462554625646257462584625946260462614626246263462644626546266462674626846269462704627146272462734627446275462764627746278462794628046281462824628346284462854628646287462884628946290462914629246293462944629546296462974629846299463004630146302463034630446305463064630746308463094631046311463124631346314463154631646317463184631946320463214632246323463244632546326463274632846329463304633146332463334633446335463364633746338463394634046341463424634346344463454634646347463484634946350463514635246353463544635546356463574635846359463604636146362463634636446365463664636746368463694637046371463724637346374463754637646377463784637946380463814638246383463844638546386463874638846389463904639146392463934639446395463964639746398463994640046401464024640346404464054640646407464084640946410464114641246413464144641546416464174641846419464204642146422464234642446425464264642746428464294643046431464324643346434464354643646437464384643946440464414644246443464444644546446464474644846449464504645146452464534645446455464564645746458464594646046461464624646346464464654646646467464684646946470464714647246473464744647546476464774647846479464804648146482464834648446485464864648746488464894649046491464924649346494464954649646497464984649946500465014650246503465044650546506465074650846509465104651146512465134651446515465164651746518465194652046521465224652346524465254652646527465284652946530465314653246533465344653546536465374653846539465404654146542465434654446545465464654746548465494655046551465524655346554465554655646557465584655946560465614656246563465644656546566465674656846569465704657146572465734657446575465764657746578465794658046581465824658346584465854658646587465884658946590465914659246593465944659546596465974659846599466004660146602466034660446605466064660746608466094661046611466124661346614466154661646617466184661946620466214662246623466244662546626466274662846629466304663146632466334663446635466364663746638466394664046641466424664346644466454664646647466484664946650466514665246653466544665546656466574665846659466604666146662466634666446665466664666746668466694667046671466724667346674466754667646677466784667946680466814668246683466844668546686466874668846689466904669146692466934669446695466964669746698466994670046701467024670346704467054670646707467084670946710467114671246713467144671546716467174671846719467204672146722467234672446725467264672746728467294673046731467324673346734467354673646737467384673946740467414674246743467444674546746467474674846749467504675146752467534675446755467564675746758467594676046761467624676346764467654676646767467684676946770467714677246773467744677546776467774677846779467804678146782467834678446785467864678746788467894679046791467924679346794467954679646797467984679946800468014680246803468044680546806468074680846809468104681146812468134681446815468164681746818468194682046821468224682346824468254682646827468284682946830468314683246833468344683546836468374683846839468404684146842468434684446845468464684746848468494685046851468524685346854468554685646857468584685946860468614686246863468644686546866468674686846869468704687146872468734687446875468764687746878468794688046881468824688346884468854688646887468884688946890468914689246893468944689546896468974689846899469004690146902469034690446905469064690746908469094691046911469124691346914469154691646917469184691946920469214692246923469244692546926469274692846929469304693146932469334693446935469364693746938469394694046941469424694346944469454694646947469484694946950469514695246953469544695546956469574695846959469604696146962469634696446965469664696746968469694697046971469724697346974469754697646977469784697946980469814698246983469844698546986469874698846989469904699146992469934699446995469964699746998469994700047001470024700347004470054700647007470084700947010470114701247013470144701547016470174701847019470204702147022470234702447025470264702747028470294703047031470324703347034470354703647037470384703947040470414704247043470444704547046470474704847049470504705147052470534705447055470564705747058470594706047061470624706347064470654706647067470684706947070470714707247073470744707547076470774707847079470804708147082470834708447085470864708747088470894709047091470924709347094470954709647097470984709947100471014710247103471044710547106471074710847109471104711147112471134711447115471164711747118471194712047121471224712347124471254712647127471284712947130471314713247133471344713547136471374713847139471404714147142471434714447145471464714747148471494715047151471524715347154471554715647157471584715947160471614716247163471644716547166471674716847169471704717147172471734717447175471764717747178471794718047181471824718347184471854718647187471884718947190471914719247193471944719547196471974719847199472004720147202472034720447205472064720747208472094721047211472124721347214472154721647217472184721947220472214722247223472244722547226472274722847229472304723147232472334723447235472364723747238472394724047241472424724347244472454724647247472484724947250472514725247253472544725547256472574725847259472604726147262472634726447265472664726747268472694727047271472724727347274472754727647277472784727947280472814728247283472844728547286472874728847289472904729147292472934729447295472964729747298472994730047301473024730347304473054730647307473084730947310473114731247313473144731547316473174731847319473204732147322473234732447325473264732747328473294733047331473324733347334473354733647337473384733947340473414734247343473444734547346473474734847349473504735147352473534735447355473564735747358473594736047361473624736347364473654736647367473684736947370473714737247373473744737547376473774737847379473804738147382473834738447385473864738747388473894739047391473924739347394473954739647397473984739947400474014740247403474044740547406474074740847409474104741147412474134741447415474164741747418474194742047421474224742347424474254742647427474284742947430474314743247433474344743547436474374743847439474404744147442474434744447445474464744747448474494745047451474524745347454474554745647457474584745947460474614746247463474644746547466474674746847469474704747147472474734747447475474764747747478474794748047481474824748347484474854748647487474884748947490474914749247493474944749547496474974749847499475004750147502475034750447505475064750747508475094751047511475124751347514475154751647517475184751947520475214752247523475244752547526475274752847529475304753147532475334753447535475364753747538475394754047541475424754347544475454754647547475484754947550475514755247553475544755547556475574755847559475604756147562475634756447565475664756747568475694757047571475724757347574475754757647577475784757947580475814758247583475844758547586475874758847589475904759147592475934759447595475964759747598475994760047601476024760347604476054760647607476084760947610476114761247613476144761547616476174761847619476204762147622476234762447625476264762747628476294763047631476324763347634476354763647637476384763947640476414764247643476444764547646476474764847649476504765147652476534765447655476564765747658476594766047661476624766347664476654766647667476684766947670476714767247673476744767547676476774767847679476804768147682476834768447685476864768747688476894769047691476924769347694476954769647697476984769947700477014770247703477044770547706477074770847709477104771147712477134771447715477164771747718477194772047721477224772347724477254772647727477284772947730477314773247733477344773547736477374773847739477404774147742477434774447745477464774747748477494775047751477524775347754477554775647757477584775947760477614776247763477644776547766477674776847769477704777147772477734777447775477764777747778477794778047781477824778347784477854778647787477884778947790477914779247793477944779547796477974779847799478004780147802478034780447805478064780747808478094781047811478124781347814478154781647817478184781947820478214782247823478244782547826478274782847829478304783147832478334783447835478364783747838478394784047841478424784347844478454784647847478484784947850478514785247853478544785547856478574785847859478604786147862478634786447865478664786747868478694787047871478724787347874478754787647877478784787947880478814788247883478844788547886478874788847889478904789147892478934789447895478964789747898478994790047901479024790347904479054790647907479084790947910479114791247913479144791547916479174791847919479204792147922479234792447925479264792747928479294793047931479324793347934479354793647937479384793947940479414794247943479444794547946479474794847949479504795147952479534795447955479564795747958479594796047961479624796347964479654796647967479684796947970479714797247973479744797547976479774797847979479804798147982479834798447985479864798747988479894799047991479924799347994479954799647997479984799948000480014800248003480044800548006480074800848009480104801148012480134801448015480164801748018480194802048021480224802348024480254802648027480284802948030480314803248033480344803548036480374803848039480404804148042480434804448045480464804748048480494805048051480524805348054480554805648057480584805948060480614806248063480644806548066480674806848069480704807148072480734807448075480764807748078480794808048081480824808348084480854808648087480884808948090480914809248093480944809548096480974809848099481004810148102481034810448105481064810748108481094811048111481124811348114481154811648117481184811948120481214812248123481244812548126481274812848129481304813148132481334813448135481364813748138481394814048141481424814348144481454814648147481484814948150481514815248153481544815548156481574815848159481604816148162481634816448165481664816748168481694817048171481724817348174481754817648177481784817948180481814818248183481844818548186481874818848189481904819148192481934819448195481964819748198481994820048201482024820348204482054820648207482084820948210482114821248213482144821548216482174821848219482204822148222482234822448225482264822748228482294823048231482324823348234482354823648237482384823948240482414824248243482444824548246482474824848249482504825148252482534825448255482564825748258482594826048261482624826348264482654826648267482684826948270482714827248273482744827548276482774827848279482804828148282482834828448285482864828748288482894829048291482924829348294482954829648297482984829948300483014830248303483044830548306483074830848309483104831148312483134831448315483164831748318483194832048321483224832348324483254832648327483284832948330483314833248333483344833548336483374833848339483404834148342483434834448345483464834748348483494835048351483524835348354483554835648357483584835948360483614836248363483644836548366483674836848369483704837148372483734837448375483764837748378483794838048381483824838348384483854838648387483884838948390483914839248393483944839548396483974839848399484004840148402484034840448405484064840748408484094841048411484124841348414484154841648417484184841948420484214842248423484244842548426484274842848429484304843148432484334843448435484364843748438484394844048441484424844348444484454844648447484484844948450484514845248453484544845548456484574845848459484604846148462484634846448465484664846748468484694847048471484724847348474484754847648477484784847948480484814848248483484844848548486484874848848489484904849148492484934849448495484964849748498484994850048501485024850348504485054850648507485084850948510485114851248513485144851548516485174851848519485204852148522485234852448525485264852748528485294853048531485324853348534485354853648537485384853948540485414854248543485444854548546485474854848549485504855148552485534855448555485564855748558485594856048561485624856348564485654856648567485684856948570485714857248573485744857548576485774857848579485804858148582485834858448585485864858748588485894859048591485924859348594485954859648597485984859948600486014860248603486044860548606486074860848609486104861148612486134861448615486164861748618486194862048621486224862348624486254862648627486284862948630486314863248633486344863548636486374863848639486404864148642486434864448645486464864748648486494865048651486524865348654486554865648657486584865948660486614866248663486644866548666486674866848669486704867148672486734867448675486764867748678486794868048681486824868348684486854868648687486884868948690486914869248693486944869548696486974869848699487004870148702487034870448705487064870748708487094871048711487124871348714487154871648717487184871948720487214872248723487244872548726487274872848729487304873148732487334873448735487364873748738487394874048741487424874348744487454874648747487484874948750487514875248753487544875548756487574875848759487604876148762487634876448765487664876748768487694877048771487724877348774487754877648777487784877948780487814878248783487844878548786487874878848789487904879148792487934879448795487964879748798487994880048801488024880348804488054880648807488084880948810488114881248813488144881548816488174881848819488204882148822488234882448825488264882748828488294883048831488324883348834488354883648837488384883948840488414884248843488444884548846488474884848849488504885148852488534885448855488564885748858488594886048861488624886348864488654886648867488684886948870488714887248873488744887548876488774887848879488804888148882488834888448885488864888748888488894889048891488924889348894488954889648897488984889948900489014890248903489044890548906489074890848909489104891148912489134891448915489164891748918489194892048921489224892348924489254892648927489284892948930489314893248933489344893548936489374893848939489404894148942489434894448945489464894748948489494895048951489524895348954489554895648957489584895948960489614896248963489644896548966489674896848969489704897148972489734897448975489764897748978489794898048981489824898348984489854898648987489884898948990489914899248993489944899548996489974899848999490004900149002490034900449005490064900749008490094901049011490124901349014490154901649017490184901949020490214902249023490244902549026490274902849029490304903149032490334903449035490364903749038490394904049041490424904349044490454904649047490484904949050490514905249053490544905549056490574905849059490604906149062490634906449065490664906749068490694907049071490724907349074490754907649077490784907949080490814908249083490844908549086490874908849089490904909149092490934909449095490964909749098490994910049101491024910349104491054910649107491084910949110491114911249113491144911549116491174911849119491204912149122491234912449125491264912749128491294913049131491324913349134491354913649137491384913949140491414914249143491444914549146491474914849149491504915149152491534915449155491564915749158491594916049161491624916349164491654916649167491684916949170491714917249173491744917549176491774917849179491804918149182491834918449185491864918749188491894919049191491924919349194491954919649197491984919949200492014920249203492044920549206492074920849209492104921149212492134921449215492164921749218492194922049221492224922349224492254922649227492284922949230492314923249233492344923549236492374923849239492404924149242492434924449245492464924749248492494925049251492524925349254492554925649257492584925949260492614926249263492644926549266492674926849269492704927149272492734927449275492764927749278492794928049281492824928349284492854928649287492884928949290492914929249293492944929549296492974929849299493004930149302493034930449305493064930749308493094931049311493124931349314493154931649317493184931949320493214932249323493244932549326493274932849329493304933149332493334933449335493364933749338493394934049341493424934349344493454934649347493484934949350493514935249353493544935549356493574935849359493604936149362493634936449365493664936749368493694937049371493724937349374493754937649377493784937949380493814938249383493844938549386493874938849389493904939149392493934939449395493964939749398493994940049401494024940349404494054940649407494084940949410494114941249413494144941549416494174941849419494204942149422494234942449425494264942749428494294943049431494324943349434494354943649437494384943949440494414944249443494444944549446494474944849449494504945149452494534945449455494564945749458494594946049461494624946349464494654946649467494684946949470494714947249473494744947549476494774947849479494804948149482494834948449485494864948749488494894949049491494924949349494494954949649497494984949949500495014950249503495044950549506495074950849509495104951149512495134951449515495164951749518495194952049521495224952349524495254952649527495284952949530495314953249533495344953549536495374953849539495404954149542495434954449545495464954749548495494955049551495524955349554495554955649557495584955949560495614956249563495644956549566495674956849569495704957149572495734957449575495764957749578495794958049581495824958349584495854958649587495884958949590495914959249593495944959549596495974959849599496004960149602496034960449605496064960749608496094961049611496124961349614496154961649617496184961949620496214962249623496244962549626496274962849629496304963149632496334963449635496364963749638496394964049641496424964349644496454964649647496484964949650496514965249653496544965549656496574965849659496604966149662496634966449665496664966749668496694967049671496724967349674496754967649677496784967949680496814968249683496844968549686496874968849689496904969149692496934969449695496964969749698496994970049701497024970349704497054970649707497084970949710497114971249713497144971549716497174971849719497204972149722497234972449725497264972749728497294973049731497324973349734497354973649737497384973949740497414974249743497444974549746497474974849749497504975149752497534975449755497564975749758497594976049761497624976349764497654976649767497684976949770497714977249773497744977549776497774977849779497804978149782497834978449785497864978749788497894979049791497924979349794497954979649797497984979949800498014980249803498044980549806498074980849809498104981149812498134981449815498164981749818498194982049821498224982349824498254982649827498284982949830498314983249833498344983549836498374983849839498404984149842498434984449845498464984749848498494985049851498524985349854498554985649857498584985949860498614986249863498644986549866498674986849869498704987149872498734987449875498764987749878498794988049881498824988349884498854988649887498884988949890498914989249893498944989549896498974989849899499004990149902499034990449905499064990749908499094991049911499124991349914499154991649917499184991949920499214992249923499244992549926499274992849929499304993149932499334993449935499364993749938499394994049941499424994349944499454994649947499484994949950499514995249953499544995549956499574995849959499604996149962499634996449965499664996749968499694997049971499724997349974499754997649977499784997949980499814998249983499844998549986499874998849989499904999149992499934999449995499964999749998499995000050001500025000350004500055000650007500085000950010500115001250013500145001550016500175001850019500205002150022500235002450025500265002750028500295003050031500325003350034500355003650037500385003950040500415004250043500445004550046500475004850049500505005150052500535005450055500565005750058500595006050061500625006350064500655006650067500685006950070500715007250073500745007550076500775007850079500805008150082500835008450085500865008750088500895009050091500925009350094500955009650097500985009950100501015010250103501045010550106501075010850109501105011150112501135011450115501165011750118501195012050121501225012350124501255012650127501285012950130501315013250133501345013550136501375013850139501405014150142501435014450145501465014750148501495015050151501525015350154501555015650157501585015950160501615016250163501645016550166501675016850169501705017150172501735017450175501765017750178501795018050181501825018350184501855018650187501885018950190501915019250193501945019550196501975019850199502005020150202502035020450205502065020750208502095021050211502125021350214502155021650217502185021950220502215022250223502245022550226502275022850229502305023150232502335023450235502365023750238502395024050241502425024350244502455024650247502485024950250502515025250253502545025550256502575025850259502605026150262502635026450265502665026750268502695027050271502725027350274502755027650277502785027950280502815028250283502845028550286502875028850289502905029150292502935029450295502965029750298502995030050301503025030350304503055030650307503085030950310503115031250313503145031550316503175031850319503205032150322503235032450325503265032750328503295033050331503325033350334503355033650337503385033950340503415034250343503445034550346503475034850349503505035150352503535035450355503565035750358503595036050361503625036350364503655036650367503685036950370503715037250373503745037550376503775037850379503805038150382503835038450385503865038750388503895039050391503925039350394503955039650397503985039950400504015040250403504045040550406504075040850409504105041150412504135041450415504165041750418504195042050421504225042350424504255042650427504285042950430504315043250433504345043550436504375043850439504405044150442504435044450445504465044750448504495045050451504525045350454504555045650457504585045950460504615046250463504645046550466504675046850469504705047150472504735047450475504765047750478504795048050481504825048350484504855048650487504885048950490504915049250493504945049550496504975049850499505005050150502505035050450505505065050750508505095051050511505125051350514505155051650517505185051950520505215052250523505245052550526505275052850529505305053150532505335053450535505365053750538505395054050541505425054350544505455054650547505485054950550505515055250553505545055550556505575055850559505605056150562505635056450565505665056750568505695057050571505725057350574505755057650577505785057950580505815058250583505845058550586505875058850589505905059150592505935059450595505965059750598505995060050601506025060350604506055060650607506085060950610506115061250613506145061550616506175061850619506205062150622506235062450625506265062750628506295063050631506325063350634506355063650637506385063950640506415064250643506445064550646506475064850649506505065150652506535065450655506565065750658506595066050661506625066350664506655066650667506685066950670506715067250673506745067550676506775067850679506805068150682506835068450685506865068750688506895069050691506925069350694506955069650697506985069950700507015070250703507045070550706507075070850709507105071150712507135071450715507165071750718507195072050721507225072350724507255072650727507285072950730507315073250733507345073550736507375073850739507405074150742507435074450745507465074750748507495075050751507525075350754507555075650757507585075950760507615076250763507645076550766507675076850769507705077150772507735077450775507765077750778507795078050781507825078350784507855078650787507885078950790507915079250793507945079550796507975079850799508005080150802508035080450805508065080750808508095081050811508125081350814508155081650817508185081950820508215082250823508245082550826508275082850829508305083150832508335083450835508365083750838508395084050841508425084350844508455084650847508485084950850508515085250853508545085550856508575085850859508605086150862508635086450865508665086750868508695087050871508725087350874508755087650877508785087950880508815088250883508845088550886508875088850889508905089150892508935089450895508965089750898508995090050901509025090350904509055090650907509085090950910509115091250913509145091550916509175091850919509205092150922509235092450925509265092750928509295093050931509325093350934509355093650937509385093950940509415094250943509445094550946509475094850949509505095150952509535095450955509565095750958509595096050961509625096350964509655096650967509685096950970509715097250973509745097550976509775097850979509805098150982509835098450985509865098750988509895099050991509925099350994509955099650997509985099951000510015100251003510045100551006510075100851009510105101151012510135101451015510165101751018510195102051021510225102351024510255102651027510285102951030510315103251033510345103551036510375103851039510405104151042510435104451045510465104751048510495105051051510525105351054510555105651057510585105951060510615106251063510645106551066510675106851069510705107151072510735107451075510765107751078510795108051081510825108351084510855108651087510885108951090510915109251093510945109551096510975109851099511005110151102511035110451105511065110751108511095111051111511125111351114511155111651117511185111951120511215112251123511245112551126511275112851129511305113151132511335113451135511365113751138511395114051141511425114351144511455114651147511485114951150511515115251153511545115551156511575115851159511605116151162511635116451165511665116751168511695117051171511725117351174511755117651177511785117951180511815118251183511845118551186511875118851189511905119151192511935119451195511965119751198511995120051201512025120351204512055120651207512085120951210512115121251213512145121551216512175121851219512205122151222512235122451225512265122751228512295123051231512325123351234512355123651237512385123951240512415124251243512445124551246512475124851249512505125151252512535125451255512565125751258512595126051261512625126351264512655126651267512685126951270512715127251273512745127551276512775127851279512805128151282512835128451285512865128751288512895129051291512925129351294512955129651297512985129951300513015130251303513045130551306513075130851309513105131151312513135131451315513165131751318513195132051321513225132351324513255132651327513285132951330513315133251333513345133551336513375133851339513405134151342513435134451345513465134751348513495135051351513525135351354513555135651357513585135951360513615136251363513645136551366513675136851369513705137151372513735137451375513765137751378513795138051381513825138351384513855138651387513885138951390513915139251393513945139551396513975139851399514005140151402514035140451405514065140751408514095141051411514125141351414514155141651417514185141951420514215142251423514245142551426514275142851429514305143151432514335143451435514365143751438514395144051441514425144351444514455144651447514485144951450514515145251453514545145551456514575145851459514605146151462514635146451465514665146751468514695147051471514725147351474514755147651477514785147951480514815148251483514845148551486514875148851489514905149151492514935149451495514965149751498514995150051501515025150351504515055150651507515085150951510515115151251513515145151551516515175151851519515205152151522515235152451525515265152751528515295153051531515325153351534515355153651537515385153951540515415154251543515445154551546515475154851549515505155151552515535155451555515565155751558515595156051561515625156351564515655156651567515685156951570515715157251573515745157551576515775157851579515805158151582515835158451585515865158751588515895159051591515925159351594515955159651597515985159951600516015160251603516045160551606516075160851609516105161151612516135161451615516165161751618516195162051621516225162351624516255162651627516285162951630516315163251633516345163551636516375163851639516405164151642516435164451645516465164751648516495165051651516525165351654516555165651657516585165951660516615166251663516645166551666516675166851669516705167151672516735167451675516765167751678516795168051681516825168351684516855168651687516885168951690516915169251693516945169551696516975169851699517005170151702517035170451705517065170751708517095171051711517125171351714517155171651717517185171951720517215172251723517245172551726517275172851729517305173151732517335173451735517365173751738517395174051741517425174351744517455174651747517485174951750517515175251753517545175551756517575175851759517605176151762517635176451765517665176751768517695177051771517725177351774517755177651777517785177951780517815178251783517845178551786517875178851789517905179151792517935179451795517965179751798517995180051801518025180351804518055180651807518085180951810518115181251813518145181551816518175181851819518205182151822518235182451825518265182751828518295183051831518325183351834518355183651837518385183951840518415184251843518445184551846518475184851849518505185151852518535185451855518565185751858518595186051861518625186351864518655186651867518685186951870518715187251873518745187551876518775187851879518805188151882518835188451885518865188751888518895189051891518925189351894518955189651897518985189951900519015190251903519045190551906519075190851909519105191151912519135191451915519165191751918519195192051921519225192351924519255192651927519285192951930519315193251933519345193551936519375193851939519405194151942519435194451945519465194751948519495195051951519525195351954519555195651957519585195951960519615196251963519645196551966519675196851969519705197151972519735197451975519765197751978519795198051981519825198351984519855198651987519885198951990519915199251993519945199551996519975199851999520005200152002520035200452005520065200752008520095201052011520125201352014520155201652017520185201952020520215202252023520245202552026520275202852029520305203152032520335203452035520365203752038520395204052041520425204352044520455204652047520485204952050520515205252053520545205552056520575205852059520605206152062520635206452065520665206752068520695207052071520725207352074520755207652077520785207952080520815208252083520845208552086520875208852089520905209152092520935209452095520965209752098520995210052101521025210352104521055210652107521085210952110521115211252113521145211552116521175211852119521205212152122521235212452125521265212752128521295213052131521325213352134521355213652137521385213952140521415214252143521445214552146521475214852149521505215152152521535215452155521565215752158521595216052161521625216352164521655216652167521685216952170521715217252173521745217552176521775217852179521805218152182521835218452185521865218752188521895219052191521925219352194521955219652197521985219952200522015220252203522045220552206522075220852209522105221152212522135221452215522165221752218522195222052221522225222352224522255222652227522285222952230522315223252233522345223552236522375223852239522405224152242522435224452245522465224752248522495225052251522525225352254522555225652257522585225952260522615226252263522645226552266522675226852269522705227152272522735227452275522765227752278522795228052281522825228352284522855228652287522885228952290522915229252293522945229552296522975229852299523005230152302523035230452305523065230752308523095231052311523125231352314523155231652317523185231952320523215232252323523245232552326523275232852329523305233152332523335233452335523365233752338523395234052341523425234352344523455234652347523485234952350523515235252353523545235552356523575235852359523605236152362523635236452365523665236752368523695237052371523725237352374523755237652377523785237952380523815238252383523845238552386523875238852389523905239152392523935239452395523965239752398523995240052401524025240352404524055240652407524085240952410524115241252413524145241552416524175241852419524205242152422524235242452425524265242752428524295243052431524325243352434524355243652437524385243952440524415244252443524445244552446524475244852449524505245152452524535245452455524565245752458524595246052461524625246352464524655246652467524685246952470524715247252473524745247552476524775247852479524805248152482524835248452485524865248752488524895249052491524925249352494524955249652497524985249952500525015250252503525045250552506525075250852509525105251152512525135251452515525165251752518525195252052521525225252352524525255252652527525285252952530525315253252533525345253552536525375253852539525405254152542525435254452545525465254752548525495255052551525525255352554525555255652557525585255952560525615256252563525645256552566525675256852569525705257152572525735257452575525765257752578525795258052581525825258352584525855258652587525885258952590525915259252593525945259552596525975259852599526005260152602526035260452605526065260752608526095261052611526125261352614526155261652617526185261952620526215262252623526245262552626526275262852629526305263152632526335263452635526365263752638526395264052641526425264352644526455264652647526485264952650526515265252653526545265552656526575265852659526605266152662526635266452665526665266752668526695267052671526725267352674526755267652677526785267952680526815268252683526845268552686526875268852689526905269152692526935269452695526965269752698526995270052701527025270352704527055270652707527085270952710527115271252713527145271552716527175271852719527205272152722527235272452725527265272752728527295273052731527325273352734527355273652737527385273952740527415274252743527445274552746527475274852749527505275152752527535275452755527565275752758527595276052761527625276352764527655276652767527685276952770527715277252773527745277552776527775277852779527805278152782527835278452785527865278752788527895279052791527925279352794527955279652797527985279952800528015280252803528045280552806528075280852809528105281152812528135281452815528165281752818528195282052821528225282352824528255282652827528285282952830528315283252833528345283552836528375283852839528405284152842528435284452845528465284752848528495285052851528525285352854528555285652857528585285952860528615286252863528645286552866528675286852869528705287152872528735287452875528765287752878528795288052881528825288352884528855288652887528885288952890528915289252893528945289552896528975289852899529005290152902529035290452905529065290752908529095291052911529125291352914529155291652917529185291952920529215292252923529245292552926529275292852929529305293152932529335293452935529365293752938529395294052941529425294352944529455294652947529485294952950529515295252953529545295552956529575295852959529605296152962529635296452965529665296752968529695297052971529725297352974529755297652977529785297952980529815298252983529845298552986529875298852989529905299152992529935299452995529965299752998529995300053001530025300353004530055300653007530085300953010530115301253013530145301553016530175301853019530205302153022530235302453025530265302753028530295303053031530325303353034530355303653037530385303953040530415304253043530445304553046530475304853049530505305153052530535305453055530565305753058530595306053061530625306353064530655306653067530685306953070530715307253073530745307553076530775307853079530805308153082530835308453085530865308753088530895309053091530925309353094530955309653097530985309953100531015310253103531045310553106531075310853109531105311153112531135311453115531165311753118531195312053121531225312353124531255312653127531285312953130531315313253133531345313553136531375313853139531405314153142531435314453145531465314753148531495315053151531525315353154531555315653157531585315953160531615316253163531645316553166531675316853169531705317153172531735317453175531765317753178531795318053181531825318353184531855318653187531885318953190531915319253193531945319553196531975319853199532005320153202532035320453205532065320753208532095321053211532125321353214532155321653217532185321953220532215322253223532245322553226532275322853229532305323153232532335323453235532365323753238532395324053241532425324353244532455324653247532485324953250532515325253253532545325553256532575325853259532605326153262532635326453265532665326753268532695327053271532725327353274532755327653277532785327953280532815328253283532845328553286532875328853289532905329153292532935329453295532965329753298532995330053301533025330353304533055330653307533085330953310533115331253313533145331553316533175331853319533205332153322533235332453325533265332753328533295333053331533325333353334533355333653337533385333953340533415334253343533445334553346533475334853349533505335153352533535335453355533565335753358533595336053361533625336353364533655336653367533685336953370533715337253373533745337553376533775337853379533805338153382533835338453385533865338753388533895339053391533925339353394533955339653397533985339953400534015340253403534045340553406534075340853409534105341153412534135341453415534165341753418534195342053421534225342353424534255342653427534285342953430534315343253433534345343553436534375343853439534405344153442534435344453445534465344753448534495345053451534525345353454534555345653457534585345953460534615346253463534645346553466534675346853469534705347153472534735347453475534765347753478534795348053481534825348353484534855348653487534885348953490534915349253493534945349553496534975349853499535005350153502535035350453505535065350753508535095351053511535125351353514535155351653517535185351953520535215352253523535245352553526535275352853529535305353153532535335353453535535365353753538535395354053541535425354353544535455354653547535485354953550535515355253553535545355553556535575355853559535605356153562535635356453565535665356753568535695357053571535725357353574535755357653577535785357953580535815358253583535845358553586535875358853589535905359153592535935359453595535965359753598535995360053601536025360353604536055360653607536085360953610536115361253613536145361553616536175361853619536205362153622536235362453625536265362753628536295363053631536325363353634536355363653637536385363953640536415364253643536445364553646536475364853649536505365153652536535365453655536565365753658536595366053661536625366353664536655366653667536685366953670536715367253673536745367553676536775367853679536805368153682536835368453685536865368753688536895369053691536925369353694536955369653697536985369953700537015370253703537045370553706537075370853709537105371153712537135371453715537165371753718537195372053721537225372353724537255372653727537285372953730537315373253733537345373553736537375373853739537405374153742537435374453745537465374753748537495375053751537525375353754537555375653757537585375953760537615376253763537645376553766537675376853769537705377153772537735377453775537765377753778537795378053781537825378353784537855378653787537885378953790537915379253793537945379553796537975379853799538005380153802538035380453805538065380753808538095381053811538125381353814538155381653817538185381953820538215382253823538245382553826538275382853829538305383153832538335383453835538365383753838538395384053841538425384353844538455384653847538485384953850538515385253853538545385553856538575385853859538605386153862538635386453865538665386753868538695387053871538725387353874538755387653877538785387953880538815388253883538845388553886538875388853889538905389153892538935389453895538965389753898538995390053901539025390353904539055390653907539085390953910539115391253913539145391553916539175391853919539205392153922539235392453925539265392753928539295393053931539325393353934539355393653937539385393953940539415394253943539445394553946539475394853949539505395153952539535395453955539565395753958539595396053961539625396353964539655396653967539685396953970539715397253973539745397553976539775397853979539805398153982539835398453985539865398753988539895399053991539925399353994539955399653997539985399954000540015400254003540045400554006540075400854009540105401154012540135401454015540165401754018540195402054021540225402354024540255402654027540285402954030540315403254033540345403554036540375403854039540405404154042540435404454045540465404754048540495405054051540525405354054540555405654057540585405954060540615406254063540645406554066540675406854069540705407154072540735407454075540765407754078540795408054081540825408354084540855408654087540885408954090540915409254093540945409554096540975409854099541005410154102541035410454105541065410754108541095411054111541125411354114541155411654117541185411954120541215412254123541245412554126541275412854129541305413154132541335413454135541365413754138541395414054141541425414354144541455414654147541485414954150541515415254153541545415554156541575415854159541605416154162541635416454165541665416754168541695417054171541725417354174541755417654177541785417954180541815418254183541845418554186541875418854189541905419154192541935419454195541965419754198541995420054201542025420354204542055420654207542085420954210542115421254213542145421554216542175421854219542205422154222542235422454225542265422754228542295423054231542325423354234542355423654237542385423954240542415424254243542445424554246542475424854249542505425154252542535425454255542565425754258542595426054261542625426354264542655426654267542685426954270542715427254273542745427554276542775427854279542805428154282542835428454285542865428754288542895429054291542925429354294542955429654297542985429954300543015430254303543045430554306543075430854309543105431154312543135431454315543165431754318543195432054321543225432354324543255432654327543285432954330543315433254333543345433554336543375433854339543405434154342543435434454345543465434754348543495435054351543525435354354543555435654357543585435954360543615436254363543645436554366543675436854369543705437154372543735437454375543765437754378543795438054381543825438354384543855438654387543885438954390543915439254393543945439554396543975439854399544005440154402544035440454405544065440754408544095441054411544125441354414544155441654417544185441954420544215442254423544245442554426544275442854429544305443154432544335443454435544365443754438544395444054441544425444354444544455444654447544485444954450544515445254453544545445554456544575445854459544605446154462544635446454465544665446754468544695447054471544725447354474544755447654477544785447954480544815448254483544845448554486544875448854489544905449154492544935449454495544965449754498544995450054501545025450354504545055450654507545085450954510545115451254513545145451554516545175451854519545205452154522545235452454525545265452754528545295453054531545325453354534545355453654537545385453954540545415454254543545445454554546545475454854549545505455154552545535455454555545565455754558545595456054561545625456354564545655456654567545685456954570545715457254573545745457554576545775457854579545805458154582545835458454585545865458754588545895459054591545925459354594545955459654597545985459954600546015460254603546045460554606546075460854609546105461154612546135461454615546165461754618546195462054621546225462354624546255462654627546285462954630546315463254633546345463554636546375463854639546405464154642546435464454645546465464754648546495465054651546525465354654546555465654657546585465954660546615466254663546645466554666546675466854669546705467154672546735467454675546765467754678546795468054681546825468354684546855468654687546885468954690546915469254693546945469554696546975469854699547005470154702547035470454705547065470754708547095471054711547125471354714547155471654717547185471954720547215472254723547245472554726547275472854729547305473154732547335473454735547365473754738547395474054741547425474354744547455474654747547485474954750547515475254753547545475554756547575475854759547605476154762547635476454765547665476754768547695477054771547725477354774547755477654777547785477954780547815478254783547845478554786547875478854789547905479154792547935479454795547965479754798547995480054801548025480354804548055480654807548085480954810548115481254813548145481554816548175481854819548205482154822548235482454825548265482754828548295483054831548325483354834548355483654837548385483954840548415484254843548445484554846548475484854849548505485154852548535485454855548565485754858548595486054861548625486354864548655486654867548685486954870548715487254873548745487554876548775487854879548805488154882548835488454885548865488754888548895489054891548925489354894548955489654897548985489954900549015490254903549045490554906549075490854909549105491154912549135491454915549165491754918549195492054921549225492354924549255492654927549285492954930549315493254933549345493554936549375493854939549405494154942549435494454945549465494754948549495495054951549525495354954549555495654957549585495954960549615496254963549645496554966549675496854969549705497154972549735497454975549765497754978549795498054981549825498354984549855498654987549885498954990549915499254993549945499554996549975499854999550005500155002550035500455005550065500755008550095501055011550125501355014550155501655017550185501955020550215502255023550245502555026550275502855029550305503155032550335503455035550365503755038550395504055041550425504355044550455504655047550485504955050550515505255053550545505555056550575505855059550605506155062550635506455065550665506755068550695507055071550725507355074550755507655077550785507955080550815508255083550845508555086550875508855089550905509155092550935509455095550965509755098550995510055101551025510355104551055510655107551085510955110551115511255113551145511555116551175511855119551205512155122551235512455125551265512755128551295513055131551325513355134551355513655137551385513955140551415514255143551445514555146551475514855149551505515155152551535515455155551565515755158551595516055161551625516355164551655516655167551685516955170551715517255173551745517555176551775517855179551805518155182551835518455185551865518755188551895519055191551925519355194551955519655197551985519955200552015520255203552045520555206552075520855209552105521155212552135521455215552165521755218552195522055221552225522355224552255522655227552285522955230552315523255233552345523555236552375523855239552405524155242552435524455245552465524755248552495525055251552525525355254552555525655257552585525955260552615526255263552645526555266552675526855269552705527155272552735527455275552765527755278552795528055281552825528355284552855528655287552885528955290552915529255293552945529555296552975529855299553005530155302553035530455305553065530755308553095531055311553125531355314553155531655317553185531955320553215532255323553245532555326553275532855329553305533155332553335533455335553365533755338553395534055341553425534355344553455534655347553485534955350553515535255353553545535555356553575535855359553605536155362553635536455365553665536755368553695537055371553725537355374553755537655377553785537955380553815538255383553845538555386553875538855389553905539155392553935539455395553965539755398553995540055401554025540355404554055540655407554085540955410554115541255413554145541555416554175541855419554205542155422554235542455425554265542755428554295543055431554325543355434554355543655437554385543955440554415544255443554445544555446554475544855449554505545155452554535545455455554565545755458554595546055461554625546355464554655546655467554685546955470554715547255473554745547555476554775547855479554805548155482554835548455485554865548755488554895549055491554925549355494554955549655497554985549955500555015550255503555045550555506555075550855509555105551155512555135551455515555165551755518555195552055521555225552355524555255552655527555285552955530555315553255533555345553555536555375553855539555405554155542555435554455545555465554755548555495555055551555525555355554555555555655557555585555955560555615556255563555645556555566555675556855569555705557155572555735557455575555765557755578555795558055581555825558355584555855558655587555885558955590555915559255593555945559555596555975559855599556005560155602556035560455605556065560755608556095561055611556125561355614556155561655617556185561955620556215562255623556245562555626556275562855629556305563155632556335563455635556365563755638556395564055641556425564355644556455564655647556485564955650556515565255653556545565555656556575565855659556605566155662556635566455665556665566755668556695567055671556725567355674556755567655677556785567955680556815568255683556845568555686556875568855689556905569155692556935569455695556965569755698556995570055701557025570355704557055570655707557085570955710557115571255713557145571555716557175571855719557205572155722557235572455725557265572755728557295573055731557325573355734557355573655737557385573955740557415574255743557445574555746557475574855749557505575155752557535575455755557565575755758557595576055761557625576355764557655576655767557685576955770557715577255773557745577555776557775577855779557805578155782557835578455785557865578755788557895579055791557925579355794557955579655797557985579955800558015580255803558045580555806558075580855809558105581155812558135581455815558165581755818558195582055821558225582355824558255582655827558285582955830558315583255833558345583555836558375583855839558405584155842558435584455845558465584755848558495585055851558525585355854558555585655857558585585955860558615586255863558645586555866558675586855869558705587155872558735587455875558765587755878558795588055881558825588355884558855588655887558885588955890558915589255893558945589555896558975589855899559005590155902559035590455905559065590755908559095591055911559125591355914559155591655917559185591955920559215592255923559245592555926559275592855929559305593155932559335593455935559365593755938559395594055941559425594355944559455594655947559485594955950559515595255953559545595555956559575595855959559605596155962559635596455965559665596755968559695597055971559725597355974559755597655977559785597955980559815598255983559845598555986559875598855989559905599155992559935599455995559965599755998559995600056001560025600356004560055600656007560085600956010560115601256013560145601556016560175601856019560205602156022560235602456025560265602756028560295603056031560325603356034560355603656037560385603956040560415604256043560445604556046560475604856049560505605156052560535605456055560565605756058560595606056061560625606356064560655606656067560685606956070560715607256073560745607556076560775607856079560805608156082560835608456085560865608756088560895609056091560925609356094560955609656097560985609956100561015610256103561045610556106561075610856109561105611156112561135611456115561165611756118561195612056121561225612356124561255612656127561285612956130561315613256133561345613556136561375613856139561405614156142561435614456145561465614756148561495615056151561525615356154561555615656157561585615956160561615616256163561645616556166561675616856169561705617156172561735617456175561765617756178561795618056181561825618356184561855618656187561885618956190561915619256193561945619556196561975619856199562005620156202562035620456205562065620756208562095621056211562125621356214562155621656217562185621956220562215622256223562245622556226562275622856229562305623156232562335623456235562365623756238562395624056241562425624356244562455624656247562485624956250562515625256253562545625556256562575625856259562605626156262562635626456265562665626756268562695627056271562725627356274562755627656277562785627956280562815628256283562845628556286562875628856289562905629156292562935629456295562965629756298562995630056301563025630356304563055630656307563085630956310563115631256313563145631556316563175631856319563205632156322563235632456325563265632756328563295633056331563325633356334563355633656337563385633956340563415634256343563445634556346563475634856349563505635156352563535635456355563565635756358563595636056361563625636356364563655636656367563685636956370563715637256373563745637556376563775637856379563805638156382563835638456385563865638756388563895639056391563925639356394563955639656397563985639956400564015640256403564045640556406564075640856409564105641156412564135641456415564165641756418564195642056421564225642356424564255642656427564285642956430564315643256433564345643556436564375643856439564405644156442564435644456445564465644756448564495645056451564525645356454564555645656457564585645956460564615646256463564645646556466564675646856469564705647156472564735647456475564765647756478564795648056481564825648356484564855648656487564885648956490564915649256493564945649556496564975649856499565005650156502565035650456505565065650756508565095651056511565125651356514565155651656517565185651956520565215652256523565245652556526565275652856529565305653156532565335653456535565365653756538565395654056541565425654356544565455654656547565485654956550565515655256553565545655556556565575655856559565605656156562565635656456565565665656756568565695657056571565725657356574565755657656577565785657956580565815658256583565845658556586565875658856589565905659156592565935659456595565965659756598565995660056601566025660356604566055660656607566085660956610566115661256613566145661556616566175661856619566205662156622566235662456625566265662756628566295663056631566325663356634566355663656637566385663956640566415664256643566445664556646566475664856649566505665156652566535665456655566565665756658566595666056661566625666356664566655666656667566685666956670566715667256673566745667556676566775667856679566805668156682566835668456685566865668756688566895669056691566925669356694566955669656697566985669956700567015670256703567045670556706567075670856709567105671156712567135671456715567165671756718567195672056721567225672356724567255672656727567285672956730567315673256733567345673556736567375673856739567405674156742567435674456745567465674756748567495675056751567525675356754567555675656757567585675956760567615676256763567645676556766567675676856769567705677156772567735677456775567765677756778567795678056781567825678356784567855678656787567885678956790567915679256793567945679556796567975679856799568005680156802568035680456805568065680756808568095681056811568125681356814568155681656817568185681956820568215682256823568245682556826568275682856829568305683156832568335683456835568365683756838568395684056841568425684356844568455684656847568485684956850568515685256853568545685556856568575685856859568605686156862568635686456865568665686756868568695687056871568725687356874568755687656877568785687956880568815688256883568845688556886568875688856889568905689156892568935689456895568965689756898568995690056901569025690356904569055690656907569085690956910569115691256913569145691556916569175691856919569205692156922569235692456925569265692756928569295693056931569325693356934569355693656937569385693956940569415694256943569445694556946569475694856949569505695156952569535695456955569565695756958569595696056961569625696356964569655696656967569685696956970569715697256973569745697556976569775697856979569805698156982569835698456985569865698756988569895699056991569925699356994569955699656997569985699957000570015700257003570045700557006570075700857009570105701157012570135701457015570165701757018570195702057021570225702357024570255702657027570285702957030570315703257033570345703557036570375703857039570405704157042570435704457045570465704757048570495705057051570525705357054570555705657057570585705957060570615706257063570645706557066570675706857069570705707157072570735707457075570765707757078570795708057081570825708357084570855708657087570885708957090570915709257093570945709557096570975709857099571005710157102571035710457105571065710757108571095711057111571125711357114571155711657117571185711957120571215712257123571245712557126571275712857129571305713157132571335713457135571365713757138571395714057141571425714357144571455714657147571485714957150571515715257153571545715557156571575715857159571605716157162571635716457165571665716757168571695717057171571725717357174571755717657177571785717957180571815718257183571845718557186571875718857189571905719157192571935719457195571965719757198571995720057201572025720357204572055720657207572085720957210572115721257213572145721557216572175721857219572205722157222572235722457225572265722757228572295723057231572325723357234572355723657237572385723957240572415724257243572445724557246572475724857249572505725157252572535725457255572565725757258572595726057261572625726357264572655726657267572685726957270572715727257273572745727557276572775727857279572805728157282572835728457285572865728757288572895729057291572925729357294572955729657297572985729957300573015730257303573045730557306573075730857309573105731157312573135731457315573165731757318573195732057321573225732357324573255732657327573285732957330573315733257333573345733557336573375733857339573405734157342573435734457345573465734757348573495735057351573525735357354573555735657357573585735957360573615736257363573645736557366573675736857369573705737157372573735737457375573765737757378573795738057381573825738357384573855738657387573885738957390573915739257393573945739557396573975739857399574005740157402574035740457405574065740757408574095741057411574125741357414574155741657417574185741957420574215742257423574245742557426574275742857429574305743157432574335743457435574365743757438574395744057441574425744357444574455744657447574485744957450574515745257453574545745557456574575745857459574605746157462574635746457465574665746757468574695747057471574725747357474574755747657477574785747957480574815748257483574845748557486574875748857489574905749157492574935749457495574965749757498574995750057501575025750357504575055750657507575085750957510575115751257513575145751557516575175751857519575205752157522575235752457525575265752757528575295753057531575325753357534575355753657537575385753957540575415754257543575445754557546575475754857549575505755157552575535755457555575565755757558575595756057561575625756357564575655756657567575685756957570575715757257573575745757557576575775757857579575805758157582575835758457585575865758757588575895759057591575925759357594575955759657597575985759957600576015760257603576045760557606576075760857609576105761157612576135761457615576165761757618576195762057621576225762357624576255762657627576285762957630576315763257633576345763557636576375763857639576405764157642576435764457645576465764757648576495765057651576525765357654576555765657657576585765957660576615766257663576645766557666576675766857669576705767157672576735767457675576765767757678576795768057681576825768357684576855768657687576885768957690576915769257693576945769557696576975769857699577005770157702577035770457705577065770757708577095771057711577125771357714577155771657717577185771957720577215772257723577245772557726577275772857729577305773157732577335773457735577365773757738577395774057741577425774357744577455774657747577485774957750577515775257753577545775557756577575775857759577605776157762577635776457765577665776757768577695777057771577725777357774577755777657777577785777957780577815778257783577845778557786577875778857789577905779157792577935779457795577965779757798577995780057801578025780357804578055780657807578085780957810578115781257813578145781557816578175781857819578205782157822578235782457825578265782757828578295783057831578325783357834578355783657837578385783957840578415784257843578445784557846578475784857849578505785157852578535785457855578565785757858578595786057861578625786357864578655786657867578685786957870578715787257873578745787557876578775787857879578805788157882578835788457885578865788757888578895789057891578925789357894578955789657897578985789957900579015790257903579045790557906579075790857909579105791157912579135791457915579165791757918579195792057921579225792357924579255792657927579285792957930579315793257933579345793557936579375793857939579405794157942579435794457945579465794757948579495795057951579525795357954579555795657957579585795957960579615796257963579645796557966579675796857969579705797157972579735797457975579765797757978579795798057981579825798357984 |
- //[START OF KOL.pas]
- {****************************************************************
-
- KKKKK KKKKK OOOOOOOOO LLLLL
- KKKKK KKKKK OOOOOOOOOOOOO LLLLL
- KKKKK KKKKK OOOOO OOOOO LLLLL
- KKKKK KKKKK OOOOO OOOOO LLLLL
- KKKKKKKKKK OOOOO OOOOO LLLLL
- KKKKK KKKKK OOOOO OOOOO LLLLL
- KKKKK KKKKK OOOOO OOOOO LLLLL
- KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL
- KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL
-
- Key Objects Library (C) 2000-2007 by Kladov Vladimir.
- WinCE port by Yury Sidorov.
-
- This library is free software and may be redistributed and/or modified under
- the terms of the wxWindows Library License, Version 3 or (at your option)
- any later version. The full license is in the LICENSE.txt file included
- with this distribution.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- wxWindows Library License for more details.
-
- //[VERSION]
- ****************************************************************
- * VERSION 2.80.3
- ****************************************************************
- //[END OF VERSION]
-
- K.O.L. - is a set of objects to create small programs
- with the Delphi, but without the VCL. KOL allows to
- create executables of size about 10 times smaller then
- those created with the VCL. But this does not mean that
- KOL is less power then the VCL - perhaps just the opposite...
-
- Copyright (C) 2000-2007 by Vladimir Kladov.
- mailto: bonanzas@online.sinor.ru
- Web-Page: http://bonanzas.rinet.ru
-
- WinCE port by Yury Sidorov, yury_sidorov@mail.ru
-
- See also Mirror Classes Kit (M.C.K.) which allows
- to create KOL programs visually.
-
- ****************************************************************}
-
- //[UNIT DEFINES]
- {$ifdef FPC} {$mode delphi} {$endif FPC}
- {$I KOLDEF.inc}
- {$IFDEF EXTERNAL_KOLDEFS}
- {$INCLUDE PROJECT_KOL_DEFS.INC}
- {$ENDIF}
- {$IFDEF EXTERNAL_DEFINES}
- {$INCLUDE EXTERNAL_DEFINES.INC}
- {$ENDIF EXTERNAL_DEFINES}
-
- {$DEFINE GDI}
-
- {$UNDEF LIN} {$UNDEF WIN} {$UNDEF GDI}
- {$IFDEF LINUX}
- {$DEFINE LIN}
- {$DEFINE PAS_VERSION}
- {$DEFINE NOT_USE_RICHEDIT}
- {$IFNDEF GTK}
- {$IFNDEF XQT}
- {$DEFINE GTK} // it is also possible to define GTK as a project option
- {$ENDIF XQT} // even for Windows system
- {$ENDIF GTK}
- {$ELSE} // to exploit GTK under Win32 rather then native GDI
- {$DEFINE WIN}
- {$DEFINE GDI}
- {$ENDIF}
-
- {$IFDEF GTK} {$UNDEF GDI} {$DEFINE _X_}
- {$DEFINE NOT_USE_RICHEDIT}
- {$ENDIF}
- //{$IFDEF Q_T} {$UNDEF GDI} {$DEFINE _X_} {$ENDIF}
-
- {$IFDEF WIN} {$IFDEF GDI}
- {$DEFINE WIN_GDI}
- {$ENDIF GDI} {$ENDIF WIN}
-
- {$INCLUDE delphidef.inc}
-
- {$IFDEF WIN_GDI}
- //test
- {$ENDIF WIN_GDI}
- {$IFDEF LIN}
- //test
- {$ENDIF LIN}
-
- //[START OF UNIT]
- unit KOL;
- {-}
- (*
- {*
- Please note, that KOL does not use keyword 'class'. Instead,
- poor Pascal 'object' is the base of our objects. So, remember,
- how we worked earlier with such Object Pascal's objects:
- |<br>
- - to create objects dynamically, use P<objname> instead of
- T<objname> to allocate a pointer for dynamically created
- object instance;
- |<br>
- - remember, that constructors of objects can not be virtual.
- Override procedure Init instead in your own derived objects;
- |<br>
- - rather then call constructors of objects, call global procedures
- New<objname> (e.g. NewLabel). If not, first (for virtualally
- created objects) call New( ); then call constructor Create
- (which calls Init) - but this is possible only if the constructor
- is overriden by a new one.
- |<br>
- - the operator 'is' is not applicable to objects. And operator 'as'
- is not necessary (and is not applicable too), use typecast to desired
- object type, e.g.: "PSomeObjectType( C )" inplace of "C as TSomeClassType".
- |<br>
- |<hr>
- Also remember, that IF [ MyObj: PMyObj ] THEN
-
- NOT[ with MyObj do ] BUT[ with MyObj^ do ]
-
- Though it is possible to skip '^' symbol when accessing member
- fields, methods, properties, e.g. [ MyObj.Execute; ]
- |<hr>
- |&U= <a href="#%0">%0</a><br>
- |&B=<a href="%1.htm">%0</a><br>
- |&C=<a href="%1.htm">%0</a>
- | <table border=1 cellpadding=6 width=100%>
- | <colgroup valign=top span=2>
- | <tr>
- | <td> objects </td> <td> functions by category </td>
- | </tr>
- | <td>
- <C _TObj> <B TObj>
- <C TList> <C TListEx> <C TStrList> <B TStrListEx>
- <C TTree> <C TDirList> <C TIniFile> <C TCabFile>
- <B TStream>
- <B TControl>
- <C TGraphicTool> <C TCanvas> <C TImageList> <C TIcon> <C TBitmap>
- <C TGif> <C TGifDecoder> <B TJpeg>
- <C TTimer> <C TThread> <C TTrayIcon> <C TDirChange> <B TMediaPlayer>
- <C TMenu> <C TOpenSaveDialog> <C TOpenDirDialog> <B TColorDialog>
- <C TAction> <B TActionList>
- <B Exception>
- | </td>
- | <td>
- |<a href="kol_pas.htm#visual_objects_constructors">
- Visual objects constructing functions
- |</a><br><br>
- <U Working with null-terminated and ansi strings>
- <U Small bit arrays (max 32 bits in array)>
- <U Arithmetics, geometry and other utility functions>
- <U Data sorting (quicksort implementation)>
- <U String to number and number to string conversions>
- <U 64-bit integer numbers>
- <U Floating point numbers>
- <U Date and time handling>
- <U File and directory routines>
- <U System functions and working with windows>
- <U Text in clipboard operations>
- <U Wrappers to registry API functions>
- <U WinCE specific functions>
- | </td>
- | </table>
-
- Several conditional symbols can be used in a project
- (Project | Options | Directories/Conditional Defines)
- to change code generated a bit. There are following:
- |<pre>
-
- LINUX - version for Linux (only PAS_VERSION)
- PAS_VERSION - to use Pascal version of the code.
- PARANOIA - to force short versions of asm instructions (for D5
- and below, D6 and higher use those instructions always).
- SMALLEST_CODE - to create minimal code application (affected:
- (o) SimpleGetCtlBrushHandle - returns solid silver brush
- always;
- (o) _NewWindowed
- - only default system font used by default;
- font of the parent control is not applied to its
- children automatically (but see SMALLEST_CODE_PARENTFONT);
- - fBrush always set to NIL by default (parent Brush
- is not applied);
- (o) WndProcDoEraseBkgnd
- - child controls windows are not created in WM_ERASEBKGND
- if were not created earlier (in most case, all OK
- with this - controls are created BTW);
- - SetBkColor, SetBkMode, SetBrushOrgEx are not
- called (all OK therefore)
- (o) by default, NOT_UNLOAD_RICHEDITLIB is defined if
- UNLOAD_RICHEDITLIB is not defined in project options
- (this minimizes finalization section).
- (o) _NewControl
- - BoundsRect initialized with a rectangle
- (aParent.fMarginLeft, aParent.fMarginTop,
- aParent.fMarginLeft+64, aParent.fMargin+64)
- rather then with (aParent.fMargin+aParent.fMarginLeft,
- aParent.fMargin+aParent.fMarginTop,
- aParent.fMargin+aParent.fMarginLeft+64,
- aParent.fMargin+aParent.fMarginTop+64).
- In most cases this is enough.
- (o) Int2Hex
- there are no check for second perameter > 15
- (o) .... other see in code
- SMALLER_CODE - like smallest code, but fuctionality is the same.
- The speed can be lower therefore.
- SMALLEST_CODE_PARENTFONT - Parent font therefore is applied for child controls,
- but initially only.
- USE_NAMES - to use property Name with any TObj. This makes also
- available method TObj.FindObj( name ): PObj.
- (USE_CONSTRUCTORS - to use constructors like in VCL. Note: this option is
- not carefully tested!)
- USE_CUSTOMEXTENSIONS - to extend TControl with custom additions.
- UNICODE_CTRLS - to use Unicode versions of controls (WM_XXXXW messages,
- etc.)
- USE_MHTOOLTIP - to use MHTOOLTIP.
- USE_OnIdle - to use OnIdle event
- ENUM_DYN_HANDLERS_AFTER_RUN - to allow all the events handling even when
- AppletTerminated become TRUE.
- BUTTON_DBLCLICK - to prevent clicking buttons with double click,
- this takes smaller code but buttons can not
- be pressed with mouse fast. When SMALLEST_CODE on,
- this option also is on.
- ALL_BUTTONS_RESPOND_TO_ENTER - obvious (by default, buttons respond to key
- SPACE, since those are working this way in Windows).
- CLICK_DEFAULT_CANCEL_BTN_DIRECTLY - to prevent visual effect of default/cancel
- button pressing with Enter/Escape keys. Also, button
- don't become focused in such case.
- DEFAULT_CANCEL_BTN_EXCLUSIVE - to disable assigning to a button properties
- DefaultBtn and CancelBtn simultaneously.
- NO_DEFAULT_BUTTON_BOLD - to prevent DefaultBtn to be visually with
- a bold border.
- BITBTN_DISABLEDGLYPH2 - to restore old behaviour of multi-glyph bitbtn, when
- index 2 was used to represent the button in disabled
- state, and glyph with index 1 was used forpressed dtate.
- Now by default index 1 corresponds to the disabled state,
- and index 2 to the pressed state, i.e. these are swapped.
- ESC_CLOSE_DIALOGS - to allow closing all dialogs with ESCAPE.
- KEY_PREVIEW - form also receive WM_KEYDOWN (OnKeyDown event fired)
- SUPPORT_ONDEADCHAR - to support OnKeyDeadChar event in responce to
- WM_DEADCHAR, WM_SYSDEADCHAR
- OpenSaveDialog_Extended - to allow using custom extensions for OpenSaveDialog.
- AUTO_CONTEXT_HELP - to use automatic respond to WM_CONTEXTMENU to call
- context help.
- NOT_FIX_CURINDEX - to use old version of TControl.SetItems, which could
- lead to loose CurIndex value (e.g. for Combobox)
- NOT_FIX_MODAL - not to fix modal (if fixed, click on any window
- activates the application. If not fixed, code is
- smaller very a little, but only click on modal form
- activates the application). This does not fix calling
- MsgBox though.
- NEW_MODAL - to use extended modalness.
- USE_SETMODALRESULT - to guarantee ModalResult property assigning handling.
- USE_MENU_CURCTL - to use CurCtl property in popup menu to detect which
- control initiated a pop-up.
- NEW_MENU_ACCELL - to use new menu accelerators handling, without
- AcceleratorTable (not tested for all cases)
- USE_DROPDOWNCOUNT - to force setting combobox dropdown count.
- NOT_UNLOAD_RICHEDITLIB - to stop unload Rich Edit library in finalization
- section (to economy several byte of code).
- NOT_USE_RICHEDIT - not use richedit (it will not be possible to create richedit)
- USE_PROP - to use GetProp / SetProp (old style) in place of
- Get / SetWindowLong( wnd, GWL_USERDATA... ) (slower?)
-
- PROVIDE_EXITCODE - PostQuitMessage( value ) assigns value to ExitCode
- INITIALFORMSIZE_FIXMENU - form size initially is really the same as defined at
- design time even for forms having main menu bar
- USE_GRAPHCTLS - to use graphic (non-windowed) controls
- GRAPHCTL_XPSTYLES - to use XP themed Visual styles for drawing graphic
- controls. This does not affect windowed controls
- which visual style is controlled by the manifest.
- GRAPHCTL_HOTTRACK - to use hot-tracking also together with XP themed
- graphic controls (otherwise only static XP themed
- view is provided). Also, turn this option on if you
- want to handle OnMouseEnter and OnMouseLeabe events
- for graphic controls.
- ICON_DIFF_WH - to support icons having Width <> Height
- AUTO_REPLACE_CLEARTYPE- to replace automatically CLEARTYPE_QUALITY fonts
- with ANTIALIASED_QUALITY when running under elder
- Windows version than XP.
-
- NEW_GRADIENT - to use new gradient painting by homm (fast).
- OLD_ALIGN - to prevent using new Align by Galkov (new Align is faster).
- FILE_EXISTS_EX - to use more correct (but a bit large code in FileExists functon)
- NOT_USE_AUTOFREE4CONTROLS - from 2.40, most of control sub-objects are destroying
- using Add2AutoFree (smaller code). This option returns
- to previous behaviour (to compare size). Will be
- deprecated in future versions.
- ENDSESSION_HALT - to halt the process when WM_ENDSESSION comes.
- FILESTREAM_POSITION - in PAS_VERSION, Stream..fData.fPosition always show
- current position (for debug purposes)
- PSEUDO_THREADS - to use pseudo-threads instead of normal threads.
- WAIT_SLEEP - to sleep 10 ms in WaitForMultipleObjects loop (for PSEUDO_THREADS)
- DEBUG_MENU - to debug menu.
- DEBUG_GDIOBJECTS - to allow counting all the GDI objects used.
- CHK_BITBLT - to check BitBlt operations.
- DEBUG_ENDSESSION - to allow debugging WM_ENDSESSION handling.
- DEBUG_CREATEWINDOW - to debug CreateWindow.
- CRASH_DEBUG - to fill object memory with $DD before freeing it
- (program really crashes when the object is
- attempted to destroy more then once and in most
- cases when a destroyed object is accessed after the
- destruction).
- DEBUG - other debugging.
- EXTERNAL_DEFINES - if count of options necessary to set is very large
- Delphi ignores past of those. To avoid this problem,
- set only this option in Project's options, and place
- all other options to ExternalDefines.inc file as a
- sequence of {$DEFINE ... directives.
- But note, such file should be located in a
- project directory, but not in the directory where KOL.pas
- is located. This is enough to provide different sets
- of defines for each project.
- |</pre>
- }
- *)
- {= K.O.L - êëþ÷åâàÿ áèáëèîòåêà îáúåêòîâ. (C) Êëàäîâ Âëàäèìèð, 2000-2003.
- }
-
- //[OPTIONS]
- {$ifdef cpu86}
- {$A-} // align off, otherwise code is not good
- {$endif cpu86}
- {+}
-
- {$Q-} // no overflow check: this option makes code wrong
- {$R-} // no range checking: this option makes code wrong
- {$T-} // not typed @-operator
- //{$D+}
- //______________________________________________________________________________
- //
- //{$DEFINE INPACKAGE} // Uncomment this line while rebuild MCK package
- // for Delphi3 only, then restore the comment mark!!!!!!!!!!!!!!!!!!!!
- //______________________________________________________________________________
-
- {$IFDEF INPACKAGE} // use this symbol in packages requiring kol.pas
- {$WARNINGS OFF}
- {$DEFINE NOT_USE_AUTOFREE4CONTROLS}
- {$DEFINE PAS_VERSION}
- {$UNDEF ASM_VERSION}
- {$UNDEF ASM_UNICODE}
- {$ENDIF}
- {$IFDEF _D7orHigher}
- {$WARN UNSAFE_TYPE OFF} // Too many such warnings in Delphi7
- {$WARN UNSAFE_CODE OFF}
- {$WARN UNSAFE_CAST OFF}
- {$ENDIF}
-
- //[START OF INTERFACE]
- interface
-
- {$IFDEF NEW_ALIGN}
- {$UNDEF OLD_ALIGN}
- {$ELSE}
- {$IFNDEF OLD_ALIGN}
- {$DEFINE NEW_ALIGN}
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF OLD_ALIGN}
- {$UNDEF NEW_ALIGN}
- {$ELSE}
- {$IFNDEF NEW_ALIGN}
- {$DEFINE NEW_ALIGN}
- {$ENDIF}
- {$ENDIF}
-
- {$IFNDEF OLD_TRANSPARENT}
- {$DEFINE NEW_TRANSPARENT}
- {$ENDIF}
-
- {$IFNDEF NOT_USE_AUTOFREE4CONTROLS}
- {$DEFINE USE_AUTOFREE4CONTROLS}
- {$DEFINE USE_AUTOFREE4CHILDREN}
- {$ENDIF}
-
- {$IFDEF SMALLEST_CODE}
- {$DEFINE NOT_UNLOAD_RICHEDITLIB}
- {$DEFINE SMALLER_CODE}
- {$ENDIF}
-
- {$IFDEF NOT_USE_RICHEDIT}
- {$DEFINE NOT_UNLOAD_RICHEDITLIB}
- {$ENDIF}
-
- //{$DEFINE DEBUG_GDIOBJECTS}
- //{$DEFINE CHK_GDI}
-
- //[USES]
- uses {$IFDEF WIN}messages, windows {$IFNDEF NOT_USE_RICHEDIT}, RichEdit {$ENDIF}{$ENDIF WIN}
- {$IFDEF LIN}Libc, Xlib{$ENDIF}
- {$IFDEF GTK}, Glib2 , Gdk2, Gtk2, pango {$ENDIF GTK}
- {$IFDEF CHK_GDI}, ChkGdi {$ENDIF}
- {$ifdef FPC}{$ifdef wince}{$ifndef VER2_2_0},commctrl,commdlg,aygshell,shellapi{$endif}{$endif}{$endif};
- //[END OF USES]
-
- {$IFDEF LIN}
- {$DEFINE global_declare} {$I KOL_Linux.inc} {$UNDEF global_declare}
- ////type HDC = TGC; // from Xlib (temporary definition?)
- {$ENDIF LIN}
-
- {$ifdef wince}
- {$R KOL-CE.rc}
- {$endif wince}
-
- var
- AppTheming: boolean;
- {$IFDEF DEBUG_GDIOBJECTS}
- var
- BrushCount: Integer;
- FontCount: Integer;
- PenCount: Integer;
- {$ENDIF}
-
- {$IFDEF UNICODE_CTRLS}
- {$IFDEF _D2}
- {$ERROR 'Delphi 2 cannot compile with UNICODE_CTRLS defined!'}
- {$ENDIF}
- const
- SizeOfKOLChar = SizeOf(WideChar);
- {$ifdef wince}
- I_SKIP = -2;
- {$endif wince}
-
- type
- KOLString = WideString;
- KOL_String = type WideString;
- KOLChar = type WideChar;
- PKOLChar = PWideChar;
- PKOL_Char = type PWideChar;
- {$ELSE}
- const
- SizeOfKOLChar = SizeOf(AnsiChar);
-
- type
- KOLString = String;
- KOL_String = type String;
- KOLChar = type AnsiChar;
- PKOLChar = PAnsiChar;
- PKOL_Char = type PAnsiChar;
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_UNICODE}
- {$UNDEF PAS_VERSION}
- {$ENDIF}
- {$ENDIF}
-
- {$IFNDEF ASM_VERSION}
- {$DEFINE PAS_VERSION}
- {$ENDIF ASM_VERSION}
-
- {BCB++}(*type DWORD = Windows.DWORD;*){--BCB}
-
- {$IFDEF WIN}
- //{_#IF [DELPHI]}
- {$IFDEF WIN32}
- {$INCLUDE delphicommctrl.inc}
- {$IFDEF UNICODE_CTRLS}
- {$DEFINE interface_part} {$I KOL_unicode.inc} {$UNDEF interface_part}
- {$ENDIF UNICODE_CTRLS}
- {$ENDIF WIN32}
- //{_#ENDIF}
- {$ENDIF WIN}
-
- type
- //[_TObj DEFINITION]
-
- {-}
- _TObj = object
- {* auxiliary object type. See TObj. }
- protected
- procedure Init; virtual;
- {* Is called from a constructor to initialize created object instance
- filling its fields with 0. Can be overriden in descendant objects
- to add another initialization code there. (Main reason of intending
- is what constructors can not be virtual in poor objects). }
- {= Âûçûâàåòñÿ äëÿ èíèöèàëèçàöèè îáúåêòà. }
- public
- function VmtAddr: Pointer;
- {* Returns addres of virtual methods table of object. ? }
- {= âîçâðàùàåò àäðåñ òàáëèöû âèðòóàëüíûõ ìåòîäîâ (VMT). ? }
- end;
- {+}
-
- {++}(* TObj = class;*){--}
- PObj = {-}^{+}TObj;
- {* }
-
- {++}(* TList = class;*){--}
- PList = {-}^{+}TList;
- {* }
-
- //[TObjectMethod DECLARATION]
- TObjectMethod = procedure of object;
- {* }
- TOnEvent = procedure( Sender: PObj ) of object;
- {* This type of event is the most common - event handler when called can
- know only what object was a sender of this call. Replaces good known
- VCL TNotifyEvent event type. }
-
- TOnEventMoving = procedure( Sender: PObj; P: PRect ) of object;
-
- //[TPointerList DECLARATION]
- PPointerList = ^TPointerList;
- TPointerList = array[0..MaxInt div 4 - 1] of Pointer;
-
- { ---------------------------------------------------------------------
- TObj - base object to derive all others
- ---------------------------------------------------------------------- }
- //[TObj DEFINITION]
- TObj = {-} object( _TObj ) {+}{++}(*class*){--}
- {* Prototype for all objects of KOL. All its methods are important to
- implement objects in a manner similar to Delphi TObject class. }
- {= Áàçîâûé êëàññ äëÿ âñåõ ïðî÷èõ îáúåêòîâ KOL. }
- protected
- fRefCount: Integer;
- fOnDestroy: TOnEvent;
- {$IFDEF OLD_REFCOUNT}
- procedure DoDestroy;
- {$ENDIF}
- protected
- fAutoFree: PList;
- {* Is called from a constructor to initialize created object instance
- filling its fields with 0. Can be overriden in descendant objects
- to add another initialization code there. (Main reason of intending
- is what constructors can not be virtual in poor objects). }
- {= Âûçûâàåòñÿ äëÿ èíèöèàëèçàöèè îáúåêòà. }
- fTag: DWORD;
- {* Custom data. }
- public
- destructor Destroy; {-} virtual; {+}{++}(* override; *){--}
- {* Disposes memory, allocated to an object. Does not release huge strings,
- dynamic arrays and so on. Such memory should be freeing in overriden
- destructor. }
- {= Îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ äëÿ îáúåêòà. Íå îñâîáîæäàåò ïàìÿòü, âûäåëåííóþ
- äëÿ ñòðîê, äèíàìè÷èñêèõ ìàññèâîâ è ò.ï. Òàêàÿ ïàìÿòü äîëæíà áûòü îñâîáîæäåíà
- â ïåðåîïðåäåëåííîì äåñòðóêòîðå îáúåêòà. }
- {++}(*protected*){--}
- {++}(*
- procedure Init; virtual;
- {* Can be overriden in descendant objects
- to add initialization code there. (Main reason of intending
- is what constructors can not be virtual in poor objects). }
- *){--}
- procedure Final;
- {* It is called in destructor to perform OnDestroy event call and to
- released objects, added to fAutoFree list. }
- public
- procedure RefInc;
- {* See comments below. }
- {= Ñì. RefDec íèæå. }
- function RefDec: Integer;
- {* Decrements reference count. If it is becoming <0, and Free
- method was already called, object is (self-) destroyed. Otherwise,
- Free method does not destroy object, but only sets flag
- "Free was called".
- |<br>
- Use RefInc..RefDec to provide a block of code, where
- object can not be destroyed by call of Free method.
- This makes code more safe from intersecting flows of processing,
- where some code want to destroy object, but others suppose that it
- is yet existing.
- |<br>
- If You want to release object at the end of block RefInc..RefDec,
- do it immediately BEFORE call of last RefDec (to avoid situation,
- when object is released in result of RefDec, and attempt to
- destroy it follow leads to AV exception).
- |<br>
- Actually, this "function" is a procedure and does not return
- any sensible value. It is declared as a function for internal
- needs (to avoid creating separate code for Free method)
- }
- {= Óìåíüøàåò ñ÷åò÷èê èñïîëüçîâàíèÿ. Åñëè â ðåçóëüòàòå ñ÷åò÷èê ñòàíîâèòñÿ
- < 0, è ìåòîä Free óæå áûë âûçâàí, îáúåêò (ñàìî-) ðàçðóøàåòñÿ. Èíà÷å,
- ìåòîä Free íå ðàçðóøàåò îáúåêò, à òîëüêî óñòàíàâëèâàåò ôëàã "Free áûë
- âûçâàí".
- |<br>
- Èñïîëüçóéòå RefInc..RefDec äëÿ ïðåäîòâðàùåíèÿ ðàçðóøåíèÿ îáúåêòà íà
- íåêîòîðîì ó÷àñòêå êîäà (åñëè åñòü òàêàÿ íåîáõîäèìîñòü).
- |<br>
- Åñëè íóæíî óáèòü (âðåìåííûé) îáúåêò âìåñòå ñ ïîñëåäíèì RefDec, ñäåëàéòå
- âûçîâ Free íåìåäëåííî ÏÅÐÅÄ ïîñëåäíèì RefDec. }
- property RefCount: Integer read fRefCount;
- {* }
- {$IFDEF OLD_FREE}
- procedure Free;
- {$ELSE NEW_FREE}
- property Free: Integer read RefDec;
- {* Before calling destructor of object, checks if passed pointer is not
- nil - similar what is done in VCL for TObject. It is ALWAYS recommended
- to use Free instead of Destroy - see also comments to RefInc, RefDec. }
- {= Äî âûçîâà äåñòðóêòîðà, ïðîâåðÿåò, íå ïåðåäàí ëè nil â êà÷åñòâå ïàðàìåòðà.
- ÂÑÅÃÄÀ ðåêîìåíäóåòñÿ èñïîëüçîâàòü Free âìåñòî Destroy - ñì. òàê æå RefInc,
- RefDec. }
- {$ENDIF NEW_FREE}
-
- {-}
- // By Vyacheslav Gavrik:
- function InstanceSize: Integer;
- {* Returns a size of object instance. }
- {+}
-
- constructor Create;
- {* Constructor. Do not call it. Instead, use New<objectname> function
- call for certain object, e.g., NewLabel( AParent, 'caption' ); }
- {= Êîíñòðóêòîð. Íå ñëåäóåò âûçûâàòü åãî. Äëÿ êîíñòðóèðîâàíèÿ îáúåêòîâ,
- âûçûâàéòå ñîîòâåòñòâóþùóþ ãëîáàëüíóþ ôóíêöèþ New<èìÿ-îáúåêòà>. Íàïðèìåð,
- NewLabel( MyForm, 'Ìåòêà¹1' ); }
- {-}
- class function AncestorOfObject( Obj: Pointer ): Boolean;
- {* Is intended to replace 'is' operator, which is not applicable to objects. }
- {= }
- function VmtAddr: Pointer;
- {* Returns addres of virtual methods table of object. }
- {= âîçâðàùàåò àëðåñ òàáëèöû âèðòóàëüíûõ ìåòîäîâ (VMT). }
- {+}
- property OnDestroy: TOnEvent read fOnDestroy write fOnDestroy;
- {* This event is provided for any KOL object, so You can provide your own
- OnDestroy event for it. }
- {= Äàííîå ñîáûòèå îáåñïå÷èâàåòñÿ äëÿ âñåõ îáúåêòîâ KOL. Ïîçâîëÿåò ñäåëàòü
- ÷òî-íèáóäü â ñâÿçè ñ ðàçðóøåíèåì îáúåêòà. }
- procedure Add2AutoFree( Obj: PObj );
- {* Adds an object to the list of objects, destroyed automatically
- when the object is destroyed. Do not add here child controls of
- the TControl (these are destroyed by another way). Only non-control
- objects, which are not destroyed automatically, should be added here. }
- procedure Add2AutoFreeEx( Proc: TObjectMethod );
- {* Adds an event handler to the list of events, called in destructor.
- This method is mainly for internal use, and allows to auto-destroy
- VCL components, located on KOL form at design time (in MCK project). }
- procedure RemoveFromAutoFree( Obj: PObj );
- {* Removes an object from auto-free list }
- procedure RemoveFromAutoFreeEx( Proc: TObjectMethod );
- {* Removes a procedure from auto-free list }
- property Tag: DWORD read fTag write fTag;
- {* Custom data field. }
- protected
- {$IFDEF USE_NAMES}
- fName: String;
- fNamedObjList: Plist;
- fOwnerObj: PObj;
- {$ENDIF}
- public
- {$IFDEF USE_NAMES}
- procedure SetName( NewOwnerObj: PObj; const NewName: String);
- property Name: string read FName;
-
- property NamedObjList : PList read fNamedObjList;
- property OwnerObj: PObj read FOwnerObj;
- function FindObj(const ObjName: string): PObj;
- {$ENDIF}
- end;
- //[END OF TObj DEFINITION]
-
- { ---------------------------------------------------------------------
- TList - object to implement list of pointers (or dwords)
- ---------------------------------------------------------------------- }
- //[TList DEFINITION]
- TList = object( TObj )
- {* Simple list of pointers. It is used in KOL instead of standard VCL
- TList to store any kind data (or pointers to these ones). Can be created
- calling function NewList. }
- {= Ïðîñòîé ñïèñîê óêàçàòåëåé. }
- protected
- fItems: PPointerList;
- fCount: Integer;
- fCapacity: Integer;
- fAddBy: Integer;
- procedure SetCount(const Value: Integer);
- procedure SetAddBy(Value: Integer);
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* Destroys list, freeing memory, allocated for pointers. Programmer
- is resposible for destroying of data, referenced by the pointers. }
- {= }
- {++}(*protected*){--}
- procedure SetCapacity( Value: Integer );
- function Get( Idx: Integer ): Pointer;
- procedure Put( Idx: Integer; Value: Pointer );
- {$IFDEF USE_CONSTRUCTORS}
- procedure Init; virtual;
- {$ENDIF}
- protected
- {$IFDEF TLIST_FAST}
- fUseBlocks: Boolean;
- fBlockList: PList;
- fLastKnownBlockIdx: Integer;
- fLastKnownCountBefore: Integer;
- {$ENDIF}
- public
- procedure Clear;
- {* Makes Count equal to 0. Not responsible for freeing (or destroying)
- data, referenced by released pointers. }
- procedure Add( Value: Pointer );
- {* Adds pointer to the end of list, increasing Count by one. }
- procedure Insert( Idx: Integer; Value: Pointer );
- {* Inserts pointer before given item. Returns Idx, i.e. index of
- inserted item in the list. Indeces of items, located after insertion
- point, are increasing. To add item to the end of list, pass Count
- as index parameter. To insert item before first item, pass 0 there. }
- function IndexOf( Value: Pointer ): Integer;
- {* Searches first (from start) item pointer with given value and returns
- its index (zero-based) if found. If not found, returns -1. }
- procedure Delete( Idx: Integer );
- {* Deletes given (by index) pointer item from the list, shifting all
- follow item indeces up by one. }
- procedure DeleteRange( Idx, Len: Integer );
- {* Deletes Len items starting from Idx. }
- procedure Remove( Value: Pointer );
- {* Removes first entry of a Value in the list. }
- property Count: Integer read fCount write SetCount;
- {* Returns count of items in the list. It is possible to delete a number
- of items at the end of the list, keeping only first Count items alive,
- assigning new value to Count property (less then Count it is). }
- property Capacity: Integer read fCapacity write SetCapacity;
- {* Returns number of pointers which could be stored in the list
- without reallocating of memory. It is possible change this value
- for optimize usage of the list (for minimize number of reallocating
- memory operations). }
- property Items[ Idx: Integer ]: Pointer read Get write Put; default;
- {* Provides access (read and write) to items of the list. Please note,
- that TList is not responsible for freeing memory, referenced by stored
- pointers. }
- function Last: Pointer;
- {* Returns the last item (or nil, if the list is empty). }
- procedure Swap( Idx1, Idx2: Integer );
- {* Swaps two items in list directly (fast, but without testing of
- index bounds). }
- procedure MoveItem( OldIdx, NewIdx: Integer );
- {* Moves item to new position. Pass NewIdx >= Count to move item
- after the last one. }
- procedure Release;
- {* Especially for lists of pointers to dynamically allocated memory.
- Releases all pointed memory blocks and destroys object itself. }
- procedure ReleaseObjects;
- {* Especially for a list of objects derived from TObj.
- Calls Free for every of the object in the list, and then calls
- Free for the object itself. }
- property AddBy: Integer read fAddBy write SetAddBy;
- {* Value to increment capacity when new items are added or inserted
- and capacity need to be increased. }
- property DataMemory: PPointerList read fItems;
- {* Raw data memory. Can be used for direct access to items of a list.
- Do not use it for TLIST_FAST ! }
- procedure Assign( SrcList: PList );
- {* Copies all source list items. }
- {$IFDEF _D4orHigher}
- procedure AddItems( const AItems: array of Pointer );
- {* Adds a list of items given by a dynamic array. }
- {$ENDIF}
- function ItemAddress( Idx: Integer ): Pointer;
- {* Returns an address of memory occupying by the item with index Idx.
- (If the item is a pointer, returned value is a pointer to a pointer).
- Item with index requested must exist. }
- end;
- //[END OF TList DEFINITION]
-
- //[NewList DECLARATION]
- function NewList: PList;
- {* Returns pointer to newly created TList object. Use it instead usual
- TList.Create as it is done in VCL or XCL. }
-
- {$IFDEF _D4orHigher}
- function NewListInit( const AItems: array of Pointer ): PList;
- {* Creates a list filling it initially with certain Items. }
- {$ENDIF}
-
- procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
- {* Very fast adds Value to List elements from List[FromIdx] to List[FromIdx+Count-1].
- Given elements must exist. Count must be > 0. }
-
- procedure Free_And_Nil( var Obj );
- {* Obj.Free and Obj := nil, where Obj *MUST* be TObj or its descendant
- (TControl, TMenu, etc.) This procedure is not compatible with VCL's
- FreeAndNil, which works with TObject, since this it has another name. }
-
-
- //[DummyObjProc, DummyObjProcParam DECLARATION]
- procedure DummyObjProc( Sender: PObj );
- procedure DummyObjProcParam( Sender: PObj; Param: Pointer );
-
- {$IFDEF WIN_GDI}
- { --- threads --- }
- //[THREADS]
-
- const
- ABOVE_NORMAL_PRIORITY_CLASS = $8000; // only for Windows 2K
- BELOW_NORMAL_PRIORITY_CLASS = $4000; // and higher !
-
- type
- {++}(*TThread = class;*){--}
- PThread = {-}^{+}TThread;
-
- TThreadMethod = procedure of object;
- TThreadMethodEx = procedure( Sender: PThread; Param: Pointer ) of object;
-
- TOnThreadExecute = function(Sender:PThread): Integer of object;
- {* Event to be called when Execute method is called for TThread }
-
- { ---------------------------------------------------------------------
- TThread object
- ---------------------------------------------------------------------- }
- //[TThread DEFINITION]
- TThread = object(TObj)
- private
- function GetPriorityBoost: Boolean;
- procedure SetPriorityBoost(const Value: Boolean);
- {* Thread object. It is possible not to derive Your own thread-based
- object, but instead create thread Suspended and assign event
- OnExecute. To create, use one of NewThread of NewThreadEx functions,
- or derive Your own descendant object and write creation function
- (or constructor) for it.
- |<br><br>
- Aknowledgements. Originally class ZThread was developed for XCL:
- |<br> * By: Tim Slusher : junior@nlcomm.com
- |<br> * Home: http://www.nlcomm.com/~junior
- }
- protected
- FSuspended,
- FTerminated: boolean;
- FHandle: THandle;
- FThreadId: DWORD;
- FOnSuspend: TObjectMethod;
- FOnResume: TOnEvent;
- FData : Pointer;
- FOnExecute : TOnThreadExecute;
- FMethod: TThreadMethod;
- FMethodEx: TThreadMethodEx;
- F_AutoFree: Boolean;
- FPriority: Integer;
- function GetPriorityCls: Integer;
- function GetThrdPriority: Integer;
- procedure SetPriorityCls(Value: Integer);
- procedure SetThrdPriority(Value: Integer);
- procedure Init; virtual;
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- public
- {$IFDEF PSEUDO_THREADS}
- FPrtyCls: Integer;
- DoNotWakeUntil: DWORD;
- AllThreads: PList; // only for MainThread
- CurrentThread: PThread;
- StackBottom: Pointer; // except for MainThread
- CurStackPos: Pointer;
- Stack_Empty: Boolean;
- procedure SwitchToThread( T: PThread ); // methods of MainThread
- procedure NextThread;
- {$ENDIF}
- public
- FResult: Integer;
- function Execute: integer; virtual;
- {* Executes thread. Do not call this method from another thread! (Even do
- not call this method at all!) Instead, use Resume.
- |<br>
- Note also that in contrast to VCL, it is not necessary to create your
- own descendant object from TThread and override Execute method. In KOL,
- it is sufficient to create an instance of TThread object (see NewThread,
- NewThreadEx, NewThreadAutoFree functions) and assign OnExecute event
- handler for it. }
- procedure Resume;
- {* Continues executing. It is necessary to make call for every
- nested Suspend. }
- procedure Suspend;
- {* Suspends thread until it will be resumed. Can be called from another
- thread or from the thread itself. }
- procedure Terminate;
- {* Terminates thread. }
- function WaitFor: Integer;
- {* Waits (infinitively) until thead will be finished. }
- function WaitForTime( T: DWORD ): Integer;
- {* Waits (T milliseconds) until thead will be finished. }
-
- property Handle: THandle read FHandle;
- {* Thread handle. It is created immediately when object is created
- (using NewThread). }
- property Suspended: boolean read FSuspended;
- {* True, if suspended. }
- property Terminated: boolean read FTerminated;
- {* True, if terminated. }
- property ThreadId: DWORD read FThreadId;
- {* Thread id. }
- property PriorityClass: Integer read GetPriorityCls write SetPriorityCls;
- {* Thread priority class. One of following values: HIGH_PRIORITY_CLASS,
- IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS. }
- property ThreadPriority: Integer read GetThrdPriority write SetThrdPriority;
- {* Thread priority value. One of following values: THREAD_PRIORITY_ABOVE_NORMAL,
- THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_IDLE,
- THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_TIME_CRITICAL. }
- property Data : Pointer read FData write FData;
- {* Custom data pointer. Use it for Youe own purpose. }
-
- property OnExecute: TOnThreadExecute read FOnExecute write FOnExecute;
- {* Is called, when Execute is starting. }
- property OnSuspend: TObjectMethod read FOnSuspend write FOnSuspend;
- {* Is called, when Suspend is performed. }
- property OnResume: TOnEvent read FOnResume write FOnResume;
- {* Is called, when resumed. }
- procedure Synchronize( Method: TThreadMethod );
- {* Call it to execute given method in main thread context. Applet variable
- must exist for that time. }
- procedure SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
- {* Call it to execute given method in main thread context, with a given
- parameter. Applet variable must exist for that time. Param must not be nil. }
- {$IFDEF USE_CONSTRUCTORS}
- constructor ThreadCreate;
- constructor ThreadCreateEx( const Proc: TOnThreadExecute );
- {$ENDIF USE_CONSTRUCTORS}
-
- property AutoFree: Boolean read F_AutoFree write F_AutoFree;
- {* Set this property to true to provide automatic destroying of thread
- object when its executing is finished. }
- property PriorityBoost: Boolean read GetPriorityBoost write SetPriorityBoost;
- {* By default, priority boost is enabled for all threads. }
- end;
- //[END OF TThread DEFINITION]
-
- //[NewThread, NewThreadEx, NewThreadAutoFree DECLARATIONS]
- function NewThread: PThread;
- {* Creates thread object (always suspended). After creating, set event
- OnExecute and perform Resume operation. }
-
- function NewThreadEx( const Proc: TOnThreadExecute ): PThread; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Creates thread object, assigns Proc to its OnExecute event and runs
- it. }
-
- function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
- {* Creates thread object similar to NewThreadEx, but freeing automatically
- when executing of such thread finished. Be sure that a thread is resumed
- at least to provide its object keeper freeing. }
-
- {$IFDEF PSEUDO_THREADS}
- var MainThread: PThread;
- PseudoThreadStackSize: DWORD = 1024 * 1024;
- CreatingMainThread: Boolean;
-
- function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function WaitForMultipleObjects( nCount: DWORD;
- lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- procedure Sleep( n: DWORD );
- {$ENDIF}
-
- { -- streams -- }
- //[STREAMS]
-
- {$ENDIF WIN_GDI}
- type
- TMoveMethod = ( spBegin, spCurrent, spEnd );
- {$IFDEF WIN_GDI}
- type
- {++}(*TStream = class;*){--}
- PStream = {-}^{+}TStream;
-
- PStreamMethods = ^TStreamMethods;
- TStreamMethods = {$ifndef wince}packed{$endif} Record
- fSeek: function( Strm: PStream; MoveTo: Integer; MoveMethod: TMoveMethod ): DWORD;
- fGetSiz: function( Strm: PStream ): DWORD;
- fSetSiz: procedure( Strm: PStream; Value: DWORD );
- fRead: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- fWrite: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- fClose: procedure( Strm: PStream );
- fCustom: Pointer;
- fWait: procedure( Strm: PStream );
- end;
-
- TStreamData = {$ifndef wince}packed{$endif} Record
- fHandle: THandle;
- fCapacity, fSize, fPosition: DWORD;
- fThread: PThread;
- end;
-
- { ---------------------------------------------------------------------
- TStream - streaming objects incapsulation
- ---------------------------------------------------------------------- }
- //[TStream DEFINITION]
- TStream = object(TObj)
- {* Simple stream object. Can be opened for file, or as memory stream (see
- NewReadFileStream, NewWriteFileStream, NewMemoryStream, etc.). And, another
- type of streaming object can be derived (without inheriting new object
- type, just by writing another New...Stream method, which calls
- _NewStream and pass methods record to it). }
- protected
- fPMethods: PStreamMethods;
- fMethods: TStreamMethods;
- fMemory: Pointer;
- fData: TStreamData;
- fParam1, fParam2: DWORD; // parameters to use in thread
- function GetCapacity: DWORD;
- procedure SetCapacity(Value: DWORD);
- function DoAsyncRead( Sender: PThread ): Integer;
- function DoAsyncWrite( Sender: PThread ): Integer;
- function DoAsyncSeek( Sender: PThread ): Integer;
- protected
- function GetFileStreamHandle: THandle;
- procedure SetPosition(Value: DWord);
- function GetPosition: DWord;
- function GetSize: DWord;
- procedure SetSize(NewSize: DWord);
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- public
- function Read(var Buffer; Count: DWord): DWord;
- {* Reads Count bytes from a stream. Returns number of bytes read. }
- function Seek(MoveTo: Integer; MoveMethod: TMoveMethod): DWord;
- {* Allows to change current position or to obtain it. Property
- Position uses this method both for get and set position. }
- function Write(var Buffer; Count: DWord): DWord;
- {* Writes Count bytes from Buffer, starting from current position
- in a stream. Returns how much bytes are written. }
- function WriteVal( Value: DWORD; Count: DWORD ): DWORD;
- {* Writes maximum 4 bytes of Value to a stream. Allows writing constants
- easier than via Write. }
- function WriteStr( S: String ): DWORD;
- {* Writes string to the stream, not including ending #0. Exactly
- Length( S ) characters are written. }
- function WriteStrZ( S: String ): DWORD;
- {* Writes string, adding #0. Number of bytes written is returned. }
- {$IFDEF _D3orHigher}
- function WriteWStrZ( S: WideString ): DWORD;
- {* Writes string, adding #0. Number of bytes written is returned. }
- {$ENDIF}
- function ReadStrZ: String;
- {* Reads string, finished by #0. After reading, current position in
- the stream is set to the byte, follows #0. }
- {$IFDEF _D3orHigher}
- function ReadWStrZ: WideString;
- {* Reads string, finished by #0. After reading, current position in
- the stream is set to the byte, follows #0. }
- {$ENDIF}
- function ReadStr: String;
- {* Reads string, finished by #13, #10 or #13#10 symbols. Terminating symbols
- #13 and/or #10 are not added to the end of returned string though
- stream positioned follow it. }
- function ReadStrLen( Len: Integer ): String;
- {* Reads string of the given length Len. }
- function WriteStrEx(S: String): DWord;
- {* Writes string S to stream, also saving its size for future use by
- ReadStrEx* functions. Returns number of actually written characters. }
- function ReadStrExVar(var S: String): DWord;
- {* Reads string from stream and assigns it to S.
- Returns number of actually read characters.
- Note:
- String must be written by using WriteStrEx function.
- Return value is count of characters READ, not the length of string. }
- function ReadStrEx: String;
- {* Reads string from stream and returns it. }
- function WriteStrPas( S: String ): DWORD;
- {* Writes a string in Pascal short string format - 1 byte length, then string
- itself without trailing #0 char. S parameter length should not exceed 255
- chars, rest chars are truncated while writing. Total amount of bytes
- written is returned. }
- function ReadStrPas: String;
- {* Reads 1 byte from a stream, then treat it as a length of following string
- which is read and returned. A purpose of this function is reading strings
- written using WriteStrPas. }
- property Size: DWord read GetSize write SetSize;
- {* Returns stream size. For some custom streams, can be slow
- operation, or even always return undefined value (-1 recommended). }
- property Position: DWord read GetPosition write SetPosition;
- {* Current position. }
-
- property Memory: Pointer read fMemory;
- {* Only for memory stream. }
- property Handle: THandle read GetFileStreamHandle;
- {* Only for file stream. It is possible to check that Handle <>
- INVALID_HANDLE_VALUE to ensure that file stream is created OK. }
-
- //---------- for asynchronous operations (using thread - not tested):
- procedure SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);
- {* Changes current position asynchronously. To wait for finishing the
- operation, use method Wait. }
- procedure ReadAsync(var Buffer; Count: DWord);
- {* Reads Count bytes from a stream asynchronously. To wait finishing the
- operation, use method Wait. }
- procedure WriteAsync(var Buffer; Count: DWord);
- {* Writes Count bytes from Buffer, starting from current position
- in a stream - asynchronously. To wait finishing the operation,
- use method Wait. }
- function Busy: Boolean;
- {* Returns TRUE until finishing the last asynchronous operation
- started by calling SeekAsync, ReadAsync, WriteAsync methods. }
- procedure Wait;
- {* Waits for finishing the last asynchronous operation. }
-
- property Methods: PStreamMethods read fPMethods;
- {* Pointer to TStreamMethods record. Useful to implement custom-defined
- streams, which can access its fCustom field, or even to change
- methods when necessary. }
- property Data: TStreamData read fData;
- {* Pointer to TStreamData record. Useful to implement custom-defined
- streams, which can access Data fields directly when implemented. }
-
- property Capacity: DWORD read GetCapacity write SetCapacity;
- {* Amound of memory allocated for data (MemoryStream). }
-
- procedure SaveToFile( const Filename: KOLString; Start, CountSave: DWORD );
- {* }
-
- end;
- //[END OF TStream DEFINITION]
-
- //[_NewStream DECLARATION]
- function _NewStream( const StreamMethods: TStreamMethods ): PStream;
- {* Use this method only to define your own stream type. See also declared
- below (in KOL.pas) methods used to implement standard KOL streams. You can use it in
- your code to create streams, which are partially based on standard
- methods. }
-
- // Methods below are declared here to simplify creating your
- // own streams with some methods standard and some non-standard
- // together:
- function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
- function GetSizeFileStream( Strm: PStream ): DWORD;
- function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- var ReadFileStreamProc: function( Strm: PStream; var Buffer; Count: DWORD ): DWORD
- = ReadFileStream;
-
- function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- procedure CloseFileStream( Strm: PStream );
- function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
- function GetSizeMemStream( Strm: PStream ): DWORD;
-
- var CapacityMask: DWORD = $4000 - 1; // must be 2**n-1
- procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );
- function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- procedure CloseMemStream( Strm: PStream );
- procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );
-
- procedure DummyCloseStream( Strm: PStream );
-
- function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- procedure DummySetSize( Strm: PStream; Value: DWORD );
- procedure DummyStreamProc(Strm: PStream);
-
- //[NewFileStream DECLARATION]
- function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
- {* Creates file stream for read and write. Exact set of open attributes
- should be passed through Options parameter (see FileCreate where those
- flags are listed). }
-
- function NewReadFileStream( const FileName: KOLString ): PStream;
- {* Creates file stream for read only. }
-
- function NewWriteFileStream( const FileName: KOLString ): PStream;
- {* Creates file stream for write only. Truncating of file (if needed)
- is provided automatically. }
-
- function NewReadWriteFileStream( const FileName: KOLString ): PStream;
- {* Creates stream for read and write file. To truncate file, if it is
- necessary, change Size property. }
-
- {$IFDEF _D3orHigher}
- function NewReadFileStreamW( const FileName: WideString ): PStream;
- {* Creates file stream for read only. }
-
- function NewWriteFileStreamW( const FileName: WideString ): PStream;
- {* Creates file stream for write only. Truncating of file (if needed)
- is provided automatically. }
-
- function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
- {* Creates stream for read and write file. To truncate file, if it is
- necessary, change Size property. }
- {$ENDIF}
-
- function NewExFileStream( F: HFile ): PStream;
- {* Creates read only stream to read from opened file or pipe from the current
- position.
- When stream is destroyed, file handle still not closed (your code should do
- this) and file position is not changed (after the last read operation). }
-
- //[NewMemoryStream DECLARATION]
- function NewMemoryStream: PStream;
- {* Creates memory stream (read and write). }
-
- function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
- {* Creates memory stream on base of existing memory. It is not possible
- to write out of top bound given by Size (i.e. memory can not be resized,
- or reallocated. When stream object is destroyed this memory is not freed. }
-
- //[Stream2Stream DECLARATION]
- function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;
- {* Copies Count (or less, if the rest of Src is not sufficiently long)
- bytes from Src to Dst, but with optimizing in cases, when Src or/and
- Dst are memory streams (intermediate buffer is not allocated). }
- function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;
- {* Copies Count bytes from Src to Dst, but without any optimization.
- Unlike Stream2Stream function, it can be applied to very large streams.
- See also Stream2StreamExBufSz. }
- function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;
- {* Copies Count bytes from Src to Dst using buffer of given size, but without
- other optimizations.
- Unlike Stream2Stream function, it can be applied to very large streams }
-
- //[Resource2Stream DECLARATION]
- function Resource2Stream( DestStrm : PStream; Inst : HInst;
- ResName : PKOLChar; ResType : PKOLChar ): Integer;
- {* Loads given resource to DestStrm. Useful for non-standard
- resources to load it into memory (use memory stream for such
- purpose). Use one of following resource types to pass as ResType:
- |<pre>
- RT_ACCELERATOR Accelerator table
- RT_ANICURSOR Animated cursor
- RT_ANIICON Animated icon
- RT_BITMAP Bitmap resource
- RT_CURSOR Hardware-dependent cursor resource
- RT_DIALOG Dialog box
- RT_FONT Font resource
- RT_FONTDIR Font directory resource
- RT_GROUP_CURSOR Hardware-independent cursor resource
- RT_GROUP_ICON Hardware-independent icon resource
- RT_ICON Hardware-dependent icon resource
- RT_MENU Menu resource
- RT_MESSAGETABLE Message-table entry
- RT_RCDATA Application-defined resource (raw data)
- RT_STRING String-table entry
- RT_VERSION Version resource
- |</pre>
- |<br>For example:
- !var MemStrm: PStream;
- ! JpgObj: PJpeg;
- !......
- ! MemStrm := NewMemoryStream;
- ! JpgObj := NewJpeg;
- !......
- ! Resource2Stream( MemStrm, hInstance, 'MYJPEG', RT_RCDATA );
- ! MemStrm.Position := 0;
- ! JpgObj.LoadFromStream( MemStrm );
- ! MemStrm.Free;
- !......
- }
- {$ENDIF WIN_GDI}
-
- { -- string list objects -- }
- //[TStrList]
-
- type
- {++}(*TStrList = class;*){--}
- PStrList = {-}^{+}TStrList;
- { ---------------------------------------------------------------------
- TStrList - string list
- ---------------------------------------------------------------------- }
- //[TStrList DEFINITION]
- TStrList = object(TObj)
- {* Easy string list implementation (non-visual, just to store
- string data). It is well improved and has very high performance
- allowing to work fast with huge text files (more then megabyte
- of text data).
- |
- Please note that #0 charaster if stored in string lines, will cut it
- preventing reading the rest of a line. Be careful, if your data
- contain such characters. }
- protected
- procedure Init; virtual;
- protected
- fList: PList;
- fCount: Integer;
- fCaseSensitiveSort: Boolean;
- fTextBuf: PChar;
- fTextSiz: DWORD;
- function GetPChars(Idx: Integer): PChar;
- //procedure AddTextBuf( Src: PChar; Len: DWORD );
- protected
- function Get(Idx: integer): string;
- function GetTextStr: string;
- procedure Put(Idx: integer; const Value: string);
- procedure SetTextStr(const Value: string);
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- protected
- // by Dod:
- procedure SetValue(const AName, Value: string);
- function GetValue(const AName: string): string;
- public
- // by Dod:
- function IndexOfName(AName: string): Integer;
- {* by Dod. Returns index of line starting like Name=... }
- property Values[const AName: string]: string read GetValue write SetValue;
- {* by Dod. Returns right side of a line starting like Name=... }
- public
- function Add(const S: string): integer;
- {* Adds a string to list. }
- procedure AddStrings(Strings: PStrList);
- {* Merges string list with given one. Very fast - more preferrable to
- use than any loop with calling Add method. }
- procedure Assign(Strings: PStrList);
- {* Fills string list with strings from other one. The same as AddStrings,
- but Clear is called first. }
- procedure Clear;
- {* Makes string list empty. }
- procedure Delete(Idx: integer);
- {* Deletes string with given index (it *must* exist). }
- procedure DeleteLast;
- {* Deletes the last string (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 TStrList object. Returns TRUE if exact string found,
- otherwise nearest (greater then a pattern) string index is returned,
- and the result is FALSE. }
- procedure Insert(Idx: integer; const S: string);
- {* Inserts string before one with given index. }
- 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 must not
- contain #0 characters. Works very fast. This method is used in
- all others, working with text arrays (LoadFromFile, MergeFromFile,
- Assign, AddStrings). }
- procedure SetUnixText( const S: String; Append2List: Boolean );
- {* Allows to assign UNIX-style text (with #10 as string separator). }
- 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. }
- 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. }
- procedure AnsiSort( CaseSensitive: Boolean );
- {* Call it to sort ANSI string list. }
-
- // by Alexander Pravdin:
- protected
- fNameDelim: Char;
- function GetLineName( Idx: Integer ): String;
- procedure SetLineName( Idx: Integer; const NV: String );
- function GetLineValue(Idx: Integer): string;
- procedure SetLineValue(Idx: Integer; const Value: string);
- public
- property LineName[ Idx: Integer ]: string read GetLineName write SetLineName;
- property LineValue[ Idx: Integer ]: string read GetLineValue write SetLineValue;
- property NameDelimiter: Char read fNameDelim write fNameDelim;
- function Join( const sep: String ): String;
- {* by Sergey Shishmintzev. }
- {$IFDEF WIN_GDI}
- function LoadFromFile(const FileName: KOLstring): 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: KOLstring);
- {* Merges string list with strings in a file. Fast. }
- function SaveToFile(const FileName: KOLstring): Boolean;
- {* Stores string list to a file. }
- procedure SaveToStream(Stream: PStream);
- {* Saves string list to a stream (from current position). }
- function AppendToFile(const FileName: KOLstring): Boolean;
- {* Appends strings of string list to the end of a file. }
- {$ENDIF WIN_GDI}
- end;
- //[END OF TStrList DEFINITION]
-
- //[DefaultNameDelimiter]
- var DefaultNameDelimiter: Char = '=';
- ThsSeparator: Char = ',';
-
- //[NewStrList DECLARATION]
- function NewStrList: PStrList;
- {* Creates string list object. }
-
- {$IFDEF WIN}
- function GetFileList(const dir: string): PStrList;
- {* By Alexander Shakhaylo. Returns list of file names of the given directory. }
- {$ENDIF WIN}
-
- {$IFNDEF _FPC}
- function WStrLen( W: PWideChar ): Integer;
- {* Returns Length of null-terminated Unicode string. }
-
- {$IFDEF _D3orHigher} {$ifdef win32}
- function UTF8_2WideString( const s: AnsiString ): WideString;
- {$ENDIF}{$ENDIF}
- {$ENDIF _FPC}
-
- //[TStrListEx]
- type
- {++}(*TStrListEx = class;*){--}
- PStrListEx = {-}^{+}TStrListEx;
-
- //[TStrListEx DEFINITION]
- TStrListEx = object( TStrList )
- {* Extended string list object. Has additional capability to associate
- numbers or objects with string list items. }
- protected
- FObjects: PList;
- function GetObjects(Idx: Integer): DWORD;
- function GetObjectCount: Integer;
- procedure SetObjects(Idx: Integer; const Value: DWORD);
- procedure Init; {-}virtual;{+}{++}(*override;*){--}
- procedure ProvideObjCapacity( NewCap: Integer );
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
- {* Objects are just 32-bit values. You can treat and use it as pointers to
- any other data in the memory. But it is your task to free allocated
- memory in such case therefore.
- |<br>
- If the last item of a string list is deleted vis DeleteLast method (but
- not via Delete method), it's object still is preserved. As well, it is
- possible to set Objects[idx] for idx >= Count.
- To get know object's count, rather then strings count, use ObjectCount
- property. }
- property ObjectCount: Integer read GetObjectCount;
- {* Returns number of objects available. This value can differ from Count
- after some operations: objects are stored in the independant list and
- only synchronization is provided while using methods Delete, Insert,
- Add, AddObject, InsertObject while changing the list. }
- procedure AddStrings(Strings: PStrListEx);
- {* Merges string list with given one. Very fast - more preferrable to
- use than any loop with calling Add method. }
- procedure Assign(Strings: PStrListEx);
- {* Fills string list with strings from other one. The same as AddStrings,
- but Clear is called first. }
- procedure Clear;
- {* Makes string list empty. }
- procedure Delete(Idx: integer);
- {* Deletes string with given index (it *must* exist). }
- procedure Move(CurIndex, NewIndex: integer);
- {* Moves string to another location. }
- procedure Swap( Idx1, Idx2 : Integer );
- {* Swaps to strings with given indeces. }
- procedure Sort( CaseSensitive: Boolean );
- {* Call it to sort string list. }
- procedure AnsiSort( CaseSensitive: Boolean );
- {* Call it to sort ANSI string list. }
- function LastObj: DWORD;
- {* Object assotiated with the last string. }
- function AddObject( const S: String; Obj: DWORD ): Integer;
- {* Adds a string and associates given number with it. Index of the item added
- is returned. }
- procedure InsertObject( Before: Integer; const S: String; Obj: DWORD );
- {* Inserts a string together with object associated. }
- function IndexOfObj( Obj: Pointer ): Integer;
- {* Returns an index of a string associated with the object passed as a
- parameter. If there are no such strings, -1 is returned. }
- end;
- //[END OF TStrListEx DEFINITION]
-
- //[NewStrListEx DECLARATION]
- function NewStrListEx: PStrListEx;
- {* Creates extended string list object. }
-
- //[TWStrList]
-
- {-}
- {$IFNDEF _FPC}
- procedure WStrCopy( Dest, Src: PWideChar );
- {* Copies null-terminated Unicode string (terminated null also copied). }
- procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
- {* Copies null-terminated Unicode string (terminated null also copied). }
- function WStrCmp( W1, W2: PWideChar ): Integer;
- {* Compares two null-terminated Unicode strings. }
- {$ENDIF _FPC}
-
- {$IFDEF WIN_GDI}
- {$IFNDEF _D2} //------------------ WideString is not supported in D2 -----------
-
- type
- PWStrList = ^TWstrList;
- {* }
- //[TWstrList DEFINITION]
- TWStrList = object( TObj )
- {* String list to store Unicode (null-terminated) strings. }
- protected
- function GetCount: Integer;
- function GetItems(Idx: Integer): WideString;
- procedure SetItems(Idx: Integer; const Value: WideString);
- function GetPtrs(Idx: Integer): PWideChar;
- function GetText: WideString;
- protected
- fList: PList;
- fText: PWideChar;
- fTextBufSz: Integer;
- fTmp1, fTmp2: WideString;
- procedure Init; virtual;
- public
- procedure SetText(const Value: WideString);
- {* See also TStrList.SetText }
- destructor Destroy; virtual;
- {* }
- procedure Clear;
- {* See also TStrList.Clear }
- property Items[ Idx: Integer ]: WideString read GetItems write SetItems;
- {* See also TStrList.Items }
- property ItemPtrs[ Idx: Integer ]: PWideChar read GetPtrs;
- {* See also TStrList.ItemPtrs }
- property Count: Integer read GetCount;
- {* See also TStrList.Count }
- function Add( const W: WideString ): Integer;
- {* See also TStrList.Add }
- procedure Insert( Idx: Integer; const W: WideString );
- {* See also TStrList.Insert }
- procedure Delete( Idx: Integer );
- {* See also TStrList.Delete }
- property Text: WideString read GetText write SetText;
- {* See also TStrList.Text }
- procedure AddWStrings( WL: PWStrList );
- {* See also TStrList.AddStrings }
- procedure Assign( WL: PWStrList );
- {* See also TStrList.Assign }
- function LoadFromFile( const Filename: KOLString ): Boolean;
- {* See also TStrList.LoadFromFile }
- procedure LoadFromStream( Strm: PStream );
- {* See also TStrList.LoadFromStream }
- function MergeFromFile( const Filename: KOLString ): Boolean;
- {* See also TStrList.MergeFromFile }
- procedure MergeFromStream( Strm: PStream );
- {* See also TStrList.MergeFromStream }
- function SaveToFile( const Filename: KOLString ): Boolean;
- {* See also TStrList.SaveToFile }
- procedure SaveToStream( Strm: PStream );
- {* See also TStrList.SaveToStream }
- function AppendToFile( const Filename: KOLString ): Boolean;
- {* See also TStrList.AppendToFile }
- procedure Swap( Idx1, Idx2: Integer );
- {* See also TStrList.Swap }
- procedure Sort( CaseSensitive: Boolean );
- {* See also TStrList.Sort }
- procedure Move( IdxOld, IdxNew: Integer );
- {* See also TStrList.Move }
- function IndexOf( const s: WideString ): Integer;
- {* }
- end;
- //[END OF TWStrList DEFINITION]
-
- //[TWStrListEx]
- PWStrListEx = ^TWStrListEx;
-
- //[TWStrListEx DEFINITION]
- TWStrListEx = object( TWStrList )
- {* Extended Unicode string list (with Objects). }
- protected
- function GetObjects(Idx: Integer): DWORD;
- procedure SetObjects(Idx: Integer; const Value: DWORD);
- procedure ProvideObjectsCapacity( NewCap: Integer );
- protected
- fObjects: PList;
- procedure Init; virtual;
- public
- destructor Destroy; virtual;
- {* }
- property Objects[ Idx: Integer ]: DWORD read GetObjects write SetObjects;
- {* }
- procedure AddWStrings( WL: PWStrListEx );
- {* }
- procedure Assign( WL: PWStrListEx );
- {* }
- procedure Clear;
- {* }
- procedure Delete( Idx: Integer );
- {* }
- procedure Move( IdxOld, IdxNew: Integer );
- {* }
- function AddObject( const S: WideString; Obj: DWORD ): Integer;
- {* Adds a string and associates given number with it. Index of the item added
- is returned. }
- procedure InsertObject( Before: Integer; const S: WideString; Obj: DWORD );
- {* Inserts a string together with object associated. }
- function IndexOfObj( Obj: Pointer ): Integer;
- {* Returns an index of a string associated with the object passed as a
- parameter. If there are no such strings, -1 is returned. }
- end;
- //[END OF TWStrListEx DEFINITION]
-
- //[NewWStrList DECLARATION]
- function NewWStrList: PWStrList;
- {* Creates new TWStrList object and returns a pointer to it. }
-
- //[NewWStrListEx DECLARATION]
- function NewWStrListEx: PWStrListEx;
- {* Creates new TWStrListEx objects and returns a pointer to it. }
-
- {$ENDIF not _D2}
- {$ENDIF WIN_GDI}
-
- {$IFDEF UNICODE_CTRLS}
- {$IFNDEF _D2}
- type TKOLStrList = TWStrList;
- PKOLStrList = PWStrList;
- {$ELSE}
- type TKOLStrList = TStrList;
- PKOLStrList = PStrList;
- {$ENDIF}
- {$ELSE}
- type TKOLStrList = TStrList;
- PKOLStrList = PStrList;
- {$ENDIF}
-
- {+}
- ////////////////////////////////////////////////////////////////////////////////
- // GRAPHIC OBJECTS //
- ////////////////////////////////////////////////////////////////////////////////
- //[GRAPHIC OBJECTS]
- {
- It is very important, that the most of code, implementing graphic objets
- from this section, is included into executable ONLY if really accessed in your
- project directly (e.g., if Font or Brush properies of a control are accessed
- or changed).
- }
- type
- TColor = Integer;
- const
- //[COLOR CONSTANTS]
- clScrollBar = TColor(COLOR_SCROLLBAR or $80000000);
- clBackground = TColor(COLOR_BACKGROUND or $80000000);
- clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000);
- clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000);
- clMenu = TColor(COLOR_MENU or $80000000);
- clWindow = TColor(COLOR_WINDOW or $80000000);
- clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000);
- clMenuText = TColor(COLOR_MENUTEXT or $80000000);
- clWindowText = TColor(COLOR_WINDOWTEXT or $80000000);
- clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000);
- clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000);
- clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000);
- clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000);
- clHighlight = TColor(COLOR_HIGHLIGHT or $80000000);
- clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000);
- clBtnFace = TColor(COLOR_BTNFACE or $80000000);
- clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000);
- clGrayText = TColor(COLOR_GRAYTEXT or $80000000);
- clBtnText = TColor(COLOR_BTNTEXT or $80000000);
- clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
- clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
- cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
- cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
- clInfoText = TColor(COLOR_INFOTEXT or $80000000);
- clInfoBk = TColor(COLOR_INFOBK or $80000000);
-
- clBlack = TColor($000000);
- clMaroon = TColor($000080);
- clGreen = TColor($008000);
- clOlive = TColor($008080);
- clNavy = TColor($800000);
- clPurple = TColor($800080);
- clTeal = TColor($808000);
- clGray = TColor($808080);
- clSilver = TColor($C0C0C0);
- clRed = TColor($0000FF);
- clLime = TColor($00FF00);
- clYellow = TColor($00FFFF);
- clBlue = TColor($FF0000);
- clFuchsia = TColor($FF00FF);
- clAqua = TColor($FFFF00);
- clLtGray = TColor($C0C0C0);
- clDkGray = TColor($808080);
- clWhite = TColor($FFFFFF);
- clNone = TColor($1FFFFFFF);
- clDefault = TColor($20000000);
-
- clMoneyGreen = TColor($C0DCC0);
- clSkyBlue = TColor($F0CAA6);
- clCream = TColor($F0FBFF);
- clMedGray = TColor($A4A0A0);
-
- clGRushHiLight = TColor( $F3706C );
- clGRushLighten = TColor( $F1EEDF );
- clGRushLight = TColor( $e1cebf );
- clGRushNormal = TColor( $D1beaf );
- clGRushMedium = TColor( $b6bFc6 );
- clGRushDark = TColor( $9EACB4 );
- //[END OF COLOR CONSTANTS]
-
- const
- //[TGraphicTool FIELD OFFSET CONSTANTS]
- go_Color = 0;
- go_FontHeight = 4;
- go_FontWidth = 8;
- go_FontEscapement = 12;
- go_FontOrientation = 16;
- go_FontWeight = 20;
- go_FontItalic = 24;
- go_FontUnderline = 25;
- go_FontStrikeOut = 26;
- go_FontCharSet = 27;
- go_FontOutPrecision = 28;
- go_FontClipPrecision = 29;
- go_FontQuality = 30;
- go_FontPitch = 31;
- go_FontName = 32;
- go_BrushBitmap = 4;
- go_BrushStyle = 8;
- go_BrushLineColor = 9;
- go_PenBrushBitmap = 4;
- go_PenBrushStyle = 8;
- go_PenStyle = 9;
- go_PenWidth = 10;
- go_PenMode = 14;
- go_PenGeometric = 15;
- go_PenEndCap = 16;
- go_PenJoin = 17;
- //[END OF TGraphicTool FIELD OFFSET CONSTANTS]
-
- //[TGraphicTool]
- type
- TGraphicToolType = ( gttBrush, gttFont, gttPen );
- {* Graphic object types, mainly for internal use. }
-
- {++}(*TGraphicTool = class;*){--}
- PGraphicTool = {-}^{+}TGraphicTool;
- {* }
- TOnGraphicChange = procedure ( Sender: PGraphicTool ) of object;
- {* An event mainly for internal use. }
-
- TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
- bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
- {* Available brush styles. }
-
- TFontStyles = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
- {* Available font styles. }
- TFontStyle = set of TFontStyles;
- {* Font style is representing as a set of XFontStyles. }
- TFontPitch = (fpDefault, fpFixed, fpVariable);
- {* Availabe font pitch values. }
- TFontName = type string;
- {* Font name is represented as a string. }
- TFontCharset = 0..255;
- {* Font charset is represented by number from 0 to 255. }
- TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased
- , fqClearType);
- {* Font quality. }
-
- TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear,
- psInsideFrame);
- {* Available pen styles. For more info see Delphi or Win32 help files. }
- TPenMode = (pmBlack, pmNotMerge, pmMaskNotPen, pmNotCopy, pmMaskPenNot,
- pmNot, pmXor, pmNotMask, pmMask, pmNotXor, pmNop, pmMergePenNot,
- pmCopy, pmMergeNotPen, pmMerge, pmWhite);
- {* Available pen modes. For more info see Delphi or Win32 help files. }
- TPenEndCap = (pecRound, pecSquare, pecFlat);
- {* Avalable (for geometric pen) end cap styles. }
- TPenJoin = (pjRound, pjBevel, pjMiter);
- {* Available (for geometric pen) join styles. }
-
- //[TGdiFont]
- TGDIFont = packed record
- Height: Integer;
- Width: Integer;
- Escapement: Integer;
- Orientation: Integer;
- Weight: Integer;
- Italic: Boolean;
- Underline: Boolean;
- StrikeOut: Boolean;
- CharSet: TFontCharset;
- OutPrecision: Byte;
- ClipPrecision: Byte;
- Quality: TFontQuality;
- Pitch: TFontPitch;
- Name: array[0..LF_FACESIZE - 1] of KOLChar;
- end;
-
- //[TGDIBrush]
- TGDIBrush = packed record
- Bitmap: HBitmap;
- Style: TBrushStyle;
- LineColor: TColor;
- end;
-
- //[TGDIPen]
- TGDIPen = packed record
- BrushBitmap: HBitmap;
- BrushStyle: TBrushStyle;
- Style: TPenStyle;
- Width: Integer;
- Mode: TPenMode;
- Geometric: Boolean;
- EndCap: TPenEndCap;
- Join: TPenJoin;
- end;
-
- //[TGDIToolData]
- TGDIToolData = packed record
- Color: TColor;
- case Integer of
- 1: (Font: TGDIFont);
- 2: (Pen: TGDIPen);
- 3: (Brush: TGDIBrush);
- end;
-
- //[TNewGraphicTool]
- TNewGraphicTool = function: PGraphicTool;
-
- { ---------------------------------------------------------------------
- TGraphicTool - object to implement GDI-tools (brush, pen, font)
- ---------------------------------------------------------------------- }
- //[TGraphicTool DEFINITION]
- TGraphicTool = object( TObj )
- {* Incapsulates all GDI objects: Pen, Brush and Font. }
- protected
- fType: TGraphicToolType;
- {$IFDEF GDI}
- fHandle: THandle;
- fParentGDITool: PGraphicTool;
- {$ENDIF GDI}
- fColorRGB: TColor;
- fOnChange: TOnGraphicChange;
- fData: TGDIToolData;
- fNewProc: TNewGraphicTool;
- {$IFDEF GDI}
- fMakeHandleProc: function( Self_: PGraphicTool ): THandle;
- {$ENDIF GDI}
- procedure SetInt( const Index: Integer; Value: Integer );
- function GetInt( const Index: Integer ): Integer;
- procedure SetColor( Value: TColor );
- {$IFDEF GDI}
- function GetBrushBitmap: HBitmap; // for BCB only
- procedure SetBrushBitmap(const Value: HBitmap);
- function GetBrushStyle: TBrushStyle; // for BCB only
- {$ENDIF GDI}
- procedure SetBrushStyle(const Value: TBrushStyle);
- function GetFontName: KOLString;
- procedure SetFontName(const Value: KOLString);
- function GetFontStyle: TFontStyle;
- procedure SetFontStyle(const Value: TFontStyle);
- function GetFontWeight: Integer; // for BCB only
- procedure SetFontWeight(const Value: Integer);
- {$IFDEF GDI}
- function GetFontCharset: TFontCharset; // for BCB only
- procedure SetFontCharset(const Value: TFontCharset);
- function GetFontQuality: TFontQuality; // for BCB only
- procedure SetFontQuality(const Value: TFontQuality);
- function GetFontOrientation: Integer; // for BCB only
- procedure SetFontOrientation(Value: Integer);
- function GetFontPitch: TFontPitch; // for BCB only
- procedure SetFontPitch(const Value: TFontPitch);
- function GetPenMode: TPenMode; // for BCB only
- procedure SetPenMode(const Value: TPenMode);
- function GetPenStyle: TPenStyle; // for BCB only
- procedure SetPenStyle(const Value: TPenStyle);
- function GetGeometricPen: Boolean; // for BCB only
- procedure SetGeometricPen(const Value: Boolean);
- function GetPenEndCap: TPenEndCap; // for BCB only
- procedure SetPenEndCap(const Value: TPenEndCap);
- function GetPenJoin: TPenJoin; // for BCB only
- procedure SetPenJoin(const Value: TPenJoin);
- procedure SetLogFontStruct(const Value: TLogFont);
- function GetLogFontStruct: TLogFont;
- {$ENDIF GDI}
- protected
- procedure Changed;
- {* }
- {$IFDEF GDI}
- function GetHandle: THandle;
- {* }
- {$ENDIF GDI}
- protected
- {$IFDEF _X_}
- {$IFDEF GTK}
- fPangoFontDesc: PPangoFontDescription;
- function GetPangoFontDesc: PPangoFontDescription;
- {$ENDIF GTK}
- {$ENDIF _X_}
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- {$IFDEF _X_}
- {$IFDEF GTK}
- property FontHandle: PPangoFontDescription read GetPangoFontDesc;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- property Handle: THandle read GetHandle;
- {* Every time, when accessed, real GDI object is created (if it is
- not yet created). So, to prevent creating of the handle, use
- HandleAllocated instead of comparing Handle with value 0. }
- function HandleAllocated: Boolean;
- {* Returns True, if handle is allocated (i.e., if real GDI
- objet is created. }
- {$ENDIF GDI}
- property OnChange: TOnGraphicChange read fOnChange write fOnChange;
- {* Called, when object is changed. }
- {$IFDEF GDI}
- function ReleaseHandle: Integer;
- {* Returns Handle value (if allocated), releasing it from the
- object (so, it is no more knows about this handle and its
- HandleAllocated function returns False. }
- {$ENDIF GDI}
- property Color: TColor {index go_Color} read fData.Color write SetColor;
- {* Color is the most common property for all Pen, Brush and
- Font objects, so it is placed in its common for all of them. }
- function Assign( Value: PGraphicTool ): PGraphicTool;
- {* Assigns properties of the same (only) type graphic object,
- excluding Handle. If assigning is really leading to change
- object, procedure Changed is called. }
- {$IFDEF GDI}
- procedure AssignHandle( NewHandle: Integer );
- {* Assigns value to Handle property. }
-
- property BrushBitmap: HBitmap read {-BCB-}fData.Brush.Bitmap{+BCB+}
- {BCB++}(*GetBrushBitmap*){--BCB}
- write SetBrushBitmap;
- {* Brush bitmap. For more info about using brush bitmap,
- see Delphi or Win32 help files. }
- {$ENDIF GDI}
- property BrushStyle: TBrushStyle read {-BCB-}fData.Brush.Style{+BCB+}
- {BCB++}(*GetBrushStyle*){--BCB}
- write SetBrushStyle;
- {$IFDEF GDI}
- {* Brush style. }
- property BrushLineColor: TColor index go_BrushLineColor
- {$IFDEF F_P}
- read GetInt
- {$ELSE DELPHI}
- read {-BCB-}fData.Brush.LineColor{+BCB+}
- {BCB++}(*GetInt*){--BCB}
- {$ENDIF F_P/DELPHI}
- write SetInt;
- {* Brush line color, used to represent lines in hatched brush. Default value is clBlack. }
-
- {$ENDIF GDI}
- property FontHeight: Integer index go_FontHeight
- {$IFDEF F_P}
- read GetInt
- {$ELSE DELPHI}
- read {-BCB-}fData.Font.Height{+BCB+}
- {BCB++}(*GetInt*){--BCB}
- {$ENDIF F_P/DELPHI}
- write SetInt;
- {* Font height. Value 0 (default) seys to use system default value,
- negative values are to represent font height in "points", positive
- - in pixels. In XCL usually positive values (if not 0) are used to
- make appearance independent from different local settings. }
- {$IFDEF GDI}
- property FontWidth: Integer index go_FontWidth
- {$IFDEF F_P}
- read GetInt
- {$ELSE DELPHI}
- read {-BCB-}fData.Font.Width{+BCB+}
- {BCB++}(*GetInt*){--BCB}
- {$ENDIF F_P/DELPHI}
- write SetInt;
- {* Font width in logical units. If FontWidth = 0, then as it is said
- in Win32.hlp, "the aspect ratio of the device is matched against the
- digitization aspect ratio of the available fonts to find the closest match,
- determined by the absolute value of the difference." }
- property FontPitch: TFontPitch read {-BCB-}fData.Font.Pitch{+BCB+}
- {BCB++}(*GetFontPitch*){--BCB}
- write SetFontPitch;
- {* Font pitch. Change it very rare. }
- {$ENDIF GDI}
- property FontStyle: TFontStyle read GetFontStyle write SetFontStyle;
- {* Very useful property to control text appearance. }
- {$IFDEF GDI}
- property FontCharset: TFontCharset read {-BCB-}fData.Font.Charset{+BCB+}
- {BCB++}(*GetFontCharset*){--BCB}
- write SetFontCharset;
- {* Do not change it if You do not know what You do. }
- property FontQuality: TFontQuality read {-BCB-}fData.Font.Quality{+BCB+}
- {BCB++}(*GetFontQuality*){--BCB}
- write SetFontQuality;
- {* Font quality. }
- property FontOrientation: Integer read {-BCB-}fData.Font.Orientation{+BCB+}
- {BCB++}(*GetFontOrientation*){--BCB}
- write SetFontOrientation;
- {* It is possible to rotate text in XCL just by changing this
- property of a font (tenths of degree, i.e. value 900 represents
- 90 degree - text written from bottom to top). }
- {$ENDIF GDI}
- property FontWeight: Integer read {-BCB-}fData.Font.Weight{+BCB+}
- {BCB++}(*GetFontWeight*){--BCB}
- write SetFontWeight;
- {* Additional font weight for bold fonts (must be 0..1000). When set to
- value <> 0, fsBold is added to FontStyle. And otherwise, when set to 0,
- fsBold is removed from FontStyle. Value 700 corresponds to Bold,
- 400 to Normal. }
- property FontName: KOLString read GetFontName write SetFontName;
- {* Font face name. }
- {$IFDEF GDI}
- function IsFontTrueType: Boolean;
- {* Returns True, if font is True Type. Requires of creating of a Handle,
- if it is not yet created. }
-
- property PenWidth: Integer index go_PenWidth
- {$IFDEF F_P}
- read GetInt
- {$ELSE DELPHI}
- read {-BCB-}fData.Pen.Width{+BCB+}
- {BCB++}(*GetInt*){--BCB}
- {$ENDIF F_P/DELPHI}
- write SetInt;
- {* Value 0 means default pen width. }
- property PenStyle: TPenStyle read {-BCB-}fData.Pen.Style{+BCB+}
- {BCB++}(*GetPenStyle*){--BCB}
- write SetPenStyle;
- {* Pen style. }
- property PenMode: TPenMode read {-BCB-}fData.Pen.Mode{+BCB+}
- {BCB++}(*GetPenMode*){--BCB}
- write SetPenMode;
- {* Pen mode. }
-
- property GeometricPen: Boolean read {-BCB-}fData.Pen.Geometric{+BCB+}
- {BCB++}(*GetGeometricPen*){--BCB}
- write SetGeometricPen;
- {* True if Pen is geometric. Note, that under Win95/98 only pen styles
- psSolid, psNull, psInsideFrame are supported by OS. }
- property PenBrushStyle: TBrushStyle read {-BCB-}fData.Pen.BrushStyle{+BCB+}
- {BCB++}(*GetBrushStyle*){--BCB}
- write SetBrushStyle;
- {* Brush style for hatched geometric pen. }
- property PenBrushBitmap: HBitmap read {-BCB-}fData.Pen.BrushBitmap{+BCB+}
- {BCB++}(*GetBrushBitmap*){--BCB}
- write SetBrushBitmap;
- {* Brush bitmap for geometric pen (if assigned Pen is functioning as
- its style = BS_PATTERN, regadless of PenBrushStyle value). }
- property PenEndCap: TPenEndCap read {-BCB-}fData.Pen.EndCap{+BCB+}
- {BCB++}(*GetPenEndCap*){--BCB}
- write SetPenEndCap;
- {* Pen end cap mode - for GeometricPen only. }
- property PenJoin: TPenJoin read {-BCB-}fData.Pen.Join{+BCB+}
- {BCB++}(*GetPenJoin*){--BCB}
- write SetPenJoin;
- {* Pen join mode - for GeometricPen only. }
- property LogFontStruct: TLogFont read GetLogFontStruct write SetLogFontStruct;
- {* by Alex Pravdin: a property to change all font structure items at once. }
- {$ENDIF GDI}
- end;
- //[END OF TGraphicTool DEFINITION]
-
- //[Color2XXX FUNCTIONS]
- function Color2RGB( Color: TColor ): TColor;
- {* Function to get RGB color from system color. Parameter can be also RGB
- color, in that case result is just equal to a parameter. }
- {$IFDEF GTK}
- function Color2GDKColor( Color: TColor ): TGdkColor;
- {$ENDIF GTK}
- function ColorsMix( Color1, Color2: TColor ): TColor;
- {* Returns color, which RGB components are build as an (approximate)
- arithmetic mean of correspondent RGB components of both source
- colors (these both are first converted from system to RGB, and
- result is always RGB color). Please note: this function is fast,
- but can be not too exact. }
- {$IFDEF WIN_GDI}
- function Color2RGBQuad( Color: TColor ): TRGBQuad;
- {* Converts color to RGB, used to represent RGB values in palette entries
- (actually swaps R and B bytes). }
- function Color2Color16( Color: TColor ): WORD;
- {* Converts Color to RGB, packed to word (as it is used in format pf16bit). }
- function Color2Color15( Color: TColor ): WORD;
- {* Converts Color to RGB, packed to word (as it is used in format pf15bit). }
- {$ifdef wince}
- procedure CeFrameRect(DC: HDC; const Rect: TRect; Color: TColor);
- {$endif wince}
-
- //[DefFont VARIABLE]
- var // New TFont instances are intialized with the values in this structure:
- DefFont: TGDIFont = (
- Height: 0;
- Width: 0;
- Escapement: 0;
- Orientation: 0;
- Weight: 0;
- Italic: FALSE;
- Underline: FALSE;
- StrikeOut: FALSE;
- CharSet: 1;
- OutPrecision: 0;
- ClipPrecision: 0;
- Quality: fqDefault;
- Pitch: fpDefault;
- {$IFDEF UNICODE_CTRLS}
- Name: ( 'M', 'S', ' ', 'S', 'a', 'n', 's', ' ', 'S', 'e', 'r', 'i', 'f',
- #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
- #0, #0 );
- {$ELSE}
- Name: 'MS Sans Serif';
- {$ENDIF}
- );
- DefFontColor: TColor = clWindowText;
- {* Default font color. }
-
- //[GlobalGraphics_UseFontOrient]
- GlobalGraphics_UseFontOrient: Boolean;
- {* Global flag. If stays False (default), Orientation property of Font
- objects is ignored. This flag is set to True automatically in
- RotateFonts add-on. }
-
- {$ENDIF WIN_GDI}
- { -- Constructors for different GDI tools -- }
-
- //[New FUNCTIONS FOR TGraphicTool]
- function NewFont: PGraphicTool;
- {* Creates and returns font graphic tool object. }
- function NewBrush: PGraphicTool;
- {* Creates and returns new brush object. }
- function NewPen: PGraphicTool;
- {* Creates and returns new pen object. }
-
- { -- TCanvas object -- }
- //[TCanvas]
- const
- HandleValid = 1;
- PenValid = 2;
- BrushValid = 4;
- FontValid = 8;
- ChangingCanvas = 16;
-
- {$IFDEF WIN_GDI}
- type
- TFillStyle = (fsSurface, fsBorder);
- {* Available filling styles. For more info see Win32 or Delphi help files. }
- TFillMode = (fmAlternate, fmWinding);
- {* Available filling modes. For more info see Win32 or Delphi help files. }
- TCopyMode = Integer;
- {* Available copying modes are following:
- | cmBlackness<br>
- | cmDstInvert<br>
- | cmMergeCopy<br>
- | cmMergePaint<br>
- | cmNotSrcCopy<br>
- | cmNotSrcErase<br>
- | cmPatCopy<br>
- | cmPatInvert<br>
- | cmPatPaint<br>
- | cmSrcAnd<br>
- | cmSrcCopy<br>
- | cmSrcErase<br>
- | cmSrcInvert<br>
- | cmSrcPaint<br>
- | cmWhiteness<br>
- Also it is possible to use any other available ROP2 modes. For more info,
- see Win32 help files. }
-
- const
- cmBlackness = BLACKNESS;
- cmDstInvert = DSTINVERT;
- cmMergeCopy = MERGECOPY;
- cmMergePaint = MERGEPAINT;
- cmNotSrcCopy = NOTSRCCOPY;
- cmNotSrcErase = NOTSRCERASE;
- cmPatCopy = PATCOPY;
- cmPatInvert = PATINVERT;
- cmPatPaint = PATPAINT;
- cmSrcAnd = SRCAND;
- cmSrcCopy = SRCCOPY;
- cmSrcErase = SRCERASE;
- cmSrcInvert = SRCINVERT;
- cmSrcPaint = SRCPAINT;
- cmWhiteness = WHITENESS;
-
- {$ENDIF WIN_GDI}
- type
- {$IFDEF _X_}
- {$IFDEF GTK}
- HDC = PGdkGC;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {++}(*TCanvas = class;*){--}
- PCanvas = {-}^{+}TCanvas;
- {* }
- TOnGetHandle = function( Canvas: PCanvas ): HDC of object;
- {* For internal use mainly. }
- TOnTextArea = procedure( Sender: PCanvas; var Size : TSize; var P0 : TPoint );
- {* Event to calculate actual area, occupying by a text. It is used
- to optionally extend calculating of TextArea taking into considaration
- font Orientation property. }
-
- { ---------------------------------------------------------------------
- TCanvas - high-level drawing helper object
- ----------------------------------------------------------------------- }
- //[TCanvas DEFINITION]
- TCanvas = object( TObj )
- {* Very similar to VCL's TCanvas object. But with some changes, specific
- for KOL: there is no necessary to use canvases in all applications.
- And graphic tools objects are not created with canvas, but only
- if really accessed in program. (Actually, even if paint box used,
- only programmer decides, if to implement painting using Canvas or
- to call low level API drawing functions working directly with DC).
- Therefore TCanvas has some powerful extensions: rotated text support,
- geometric pen support - just by changing correspondent properties
- of certain graphic tool objects (Font.FontOrientation, Pen.GeometricPen).
- See also additional Font properties (Font.FontWeight, Font.FontQuality,
- etc. }
- protected
- fOwnerControl: Pointer; //PControl;
- {$IFDEF _X_}
- {$IFDEF GTK}
- fDrawable: PGdkDrawable;
- fTmpColor: PGdkColor;
- {$ENDIF GTK}
- {$ENDIF _X_}
- fHandle : HDC;
- fPenPos : TPoint;
- fState : Byte;
- fBrush, fPen: PGraphicTool;
- fFont : PGraphicTool; // order is important for ASM version
- {$IFDEF GDI}
- fCopyMode : TCopyMode;
- fOnChange: TOnEvent;
- {$ENDIF GDI}
- fOnGetHandle: TOnGetHandle;
- {$IFDEF _X_}
- {$IFDEF GTK}
- fSavedState: TGdkGCValues;
- procedure SaveState;
- procedure RestoreState;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- procedure SetHandle( Value : HDC );
- {$ENDIF GDI}
- procedure SetPenPos( const Value : TPoint );
- {$IFDEF GDI}
- procedure CreatePen;
- procedure CreateBrush;
- procedure CreateFont;
- procedure Changing;
- {$ENDIF GDI}
- procedure ObjectChanged( Sender : PGraphicTool );
- function GetBrush: PGraphicTool;
- function GetFont: PGraphicTool;
- function GetPen: PGraphicTool;
- function GetHandle: HDC;
- procedure AssignChangeEvents;
- {$IFDEF GDI}
- function GetPixels(X, Y: Integer): TColor;
- procedure SetPixels(X, Y: Integer; const Value: TColor);
- protected
- fIsPaintDC : Boolean;
- {* TRUE, if DC obtained during current WM_PAINT (or WM_ERASEBKGND?)
- processing for a control. This affects a way how Handle is released. }
- {++}(*public*){--}
- destructor Destroy;{-}virtual;{+}{++}(*override;*){--}
- {* }
- {++}(*protected*){--}
- {$ENDIF GDI}
- property OnGetHandle: TOnGetHandle read fOnGetHandle write fOnGetHandle;
- {* For internal use only. }
- {$IFDEF GDI}
- {$ENDIF GDI}
- public
- property Handle : HDC read GetHandle {$IFDEF GDI} write SetHandle {$ENDIF GDI};
- {* GDI device context object handle. Never created by
- Canvas itself (to use Canvas with memory bitmaps,
- always create DC by yourself and assign it to the
- Handle property of Canvas object, or use property
- Canvas of a bitmap). }
- property PenPos : TPoint read FPenPos write SetPenPos;
- {* Position of a pen. }
- property Pen : PGraphicTool read GetPen;
- {* Pen of Canvas object. Do not change its Pen.OnChange event value. }
- property Brush : PGraphicTool read GetBrush;
- {* Brush of Canvas object. Do not change its Brush.OnChange event value. }
- property Font : PGraphicTool read GetFont;
- {* Font of Canvas object. Do not change its Font.OnChange event value. }
- {$IFNDEF NOT_USE_KOLMATH} // if using KOLmath disabled, Arc becomes unavailable
- procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Draws arc. For more info, see Delphi TCanvas help. }
- {$ENDIF NOT_USE_KOLMATH}
- {$IFDEF GDI}
- procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Draws chord. For more info, see Delphi TCanvas help. }
- procedure DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- {* Draws rectangle to represent focused visual object.
- For more info, see Delphi TCanvas help. }
- procedure Ellipse(X1, Y1, X2, Y2: Integer);
- {* Draws an ellipse. For more info, see Delphi TCanvas help. }
- {$ENDIF GDI}
- procedure FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- {* Fills rectangle. For more info, see Delphi TCanvas help. }
- {$IFDEF GDI}
- procedure FillRgn( const Rgn : HRgn );
- {* Fills region. For more info, see Delphi TCanvas help. }
- procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle);
- {* Fills a figure with givien color, floodfilling its surface.
- For more info, see Delphi TCanvas help. }
- procedure FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- {* Draws a rectangle using Brush settings (color, etc.).
- For more info, see Delphi TCanvas help. }
- {$ENDIF GDI}
- procedure MoveTo( X, Y : Integer );
- {* Moves current PenPos to a new position.
- For more info, see Delphi TCanvas help. }
- procedure LineTo( X, Y : Integer );
- {* Draws a line from current PenPos up to new position.
- For more info, see Delphi TCanvas help. }
- {$IFDEF GDI}
- procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Draws a pie. For more info, see Delphi TCanvas help. }
- procedure Polygon(const Points: array of TPoint);
- {* Draws a polygon. For more info, see Delphi TCanvas help. }
- procedure Polyline(const Points: array of TPoint);
- {* Draws a bound for polygon. For more info, see Delphi TCanvas help. }
- procedure Rectangle(X1, Y1, X2, Y2: Integer);
- {* Draws a rectangle using current Pen and/or Brush.
- For more info, see Delphi TCanvas help. }
- procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
- {* Draws a rounded rectangle. For more info, see Delphi TCanvas help. }
- {$ENDIF GDI}
- procedure TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Draws a text. For more info, see Delphi TCanvas help. }
- procedure ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
- const Spacing: array of Integer );
- {* }
- procedure TextRect(const Rect: TRect; X, Y: Integer; const Text: KOLString);
- {* Draws a text, clipping output into given rectangle.
- For more info, see Delphi TCanvas help. }
- {$IFDEF GDI}
- procedure DrawText(Text:KOLString; var Rect:TRect; Flags:DWord);
- {* }
- {$ENDIF GDI}
- function TextExtent(const Text: KOLstring): TSize;
- {* Calculates size of a Text, using current Font settings.
- Does not need in Handle for Canvas object (if it is not
- yet allocated, temporary device context is created and used. }
- procedure TextArea( const Text : KOLString; var Sz : TSize; var P0 : TPoint );
- {* Calculates size and starting point to output Text,
- taking into considaration all Font attributes, including
- Orientation (only if GlobalGraphics_UseFontOrient flag
- is set to True, i.e. if rotated fonts are used).
- Like for TextExtent, does not need in Handle (and if this
- last is not yet allocated/assigned, temporary device context
- is created and used). }
- function TextWidth(const Text: KOLstring): Integer;
- {* Calculates text width (using TextArea). }
- function TextHeight(const Text: KOLstring): Integer;
- {* Calculates text height (using TextArea). }
- {$IFDEF GDI}
- function ClipRect: TRect;
- {* returns ClipBox. by Dmitry Zharov. }
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2} //------- WideString not supported in D2
- procedure WTextOut(X, Y: Integer; const WText: WideString); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Draws a Unicode text. }
- procedure WExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect;
- const WText: WideString; const Spacing: array of Integer );
- {* }
- procedure WDrawText(WText: WideString; var Rect:TRect; Flags:DWord);
- {* }
- procedure WTextRect(const Rect: TRect; X, Y: Integer;
- const WText: WideString);
- {* Draws a Unicode text, clipping output into given rectangle. }
- function WTextExtent( const WText: WideString ): TSize;
- {* Calculates Unicode text width and height. }
- function WTextWidth( const WText: WideString ): Integer;
- {* Calculates Unicode text width. }
- function WTextHeight( const WText: WideString ): Integer;
- {* Calculates Unicode text height. }
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- property ModeCopy : TCopyMode read fCopyMode write fCopyMode;
- {* Current copy mode. Is used in CopyRect method. }
- procedure CopyRect( const DstRect : TRect; SrcCanvas : PCanvas; const SrcRect : TRect );
- {* Copyes a rectangle from source to destination, using StretchBlt. }
- property OnChange: TOnEvent read fOnChange write fOnChange;
- {* }
- function Assign( SrcCanvas : PCanvas ) : Boolean;
- {* }
- {$ENDIF GDI}
- {$IFDEF _X_}
- protected // for _X_ case, RequiredState is protected yet (???)
- procedure ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
- {$ENDIF _X_}
- {$IFDEF GDI}
- function RequiredState( ReqState : DWORD ): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif};// public now
- {* It is possible to call this method before using Handle property
- to pass it into API calls - to provide valid combinations of
- pen, brush and font, selected into device context. This method
- can not provide valid Handle - You always must create it by
- yourself and assign to TCanvas.Handle property manually.
- To optimize assembler version, returns Handle value. }
- public
- {$ENDIF GDI}
- procedure DeselectHandles;
- {* Call this method to deselect all graphic tool objects from the canvas. }
- {$IFDEF GDI}
- property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
- {* Obvious. }
- {$ENDIF GDI}
- end;
- //[END OF TCanvas DEFINITION]
-
- //[NewCanvas DECLARATION]
- function NewCanvas( DC: HDC ): PCanvas;
- {* Use to construct Canvas on base of memory DC. }
-
- //[GlobalCanvas_OnTextArea]
- var
- GlobalCanvas_OnTextArea : TOnTextArea;
- {* Global event to extend Canvas with possible add-ons, applied
- when rotated fonts are used only (to take into consideration
- Font.Orientation property in TextArea method). }
-
- {$IFDEF WIN_GDI}
-
- { -- Image list object -- }
- //[IMAGE LIST]
-
- type
- TImageListColors = (ilcColor,ilcColor4,ilcColor8,ilcColor16,
- ilcColor24,ilcColor32,ilcColorDDB,ilcDefault);
- {* ImageList color schemes available. }
-
- TDrawingStyles = ( dsBlend25, dsBlend50, dsMask, dsTransparent );
- {* ImageList drawing styles available. }
- TDrawingStyle = Set of TDrawingStyles;
- {* Style of drawing is a combination of all available drawing styles. }
-
- TImageType = (itBitmap,itIcon,itCursor);
- {* ImageList types available. }
-
- {++}(*TImageList = class;*){--}
- PImageList = {-}^{+}TImageList;
- {* }
-
- TImgLOVrlayIdx = 1..15;
-
- { ---------------------------------------------------------------------
- TImageList - images container
- ----------------------------------------------------------------------- }
- //[TImageList DEFINITION]
- TImageList = object( TObj )
- {* ImageList incapsulation. }
- protected
- FHandle: THandle;
- FControl: Pointer; // PControl;
- fPrev, fNext: PImageList;
- FColors: TImageListColors;
- FMasked: Boolean;
- FImgWidth: Integer;
- FImgHeight: Integer;
- FDrawingStyle: TDrawingStyle;
- FBlendColor: TColor;
- fBkColor: TColor;
- FAllocBy: Integer;
- FShareImages: Boolean;
- FOverlay: array[ TImgLOVrlayIdx ] of Integer;
- function HandleNeeded : Boolean;
- procedure SetColors(const Value: TImageListColors);
- procedure SetMasked(const Value: Boolean);
- procedure SetImgWidth(const Value: Integer);
- procedure SetImgHeight(const Value: Integer);
- function GetCount: Integer;
- function GetBkColor: TColor;
- procedure SetBkColor(const Value: TColor);
- function GetBitmap: HBitmap;
- function GetMask: HBitmap;
- function GetDrawStyle : DWord;
- procedure SetAllocBy(const Value: Integer);
- function GetHandle: THandle;
- function GetOverlay(Idx: TImgLOVrlayIdx): Integer;
- procedure SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
- protected
- procedure SetHandle(const Value: THandle);
- {*}
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {*}
- property Handle : THandle read GetHandle write SetHandle;
- {* Handle of ImageList object. }
- property ShareImages : Boolean read FShareImages write FShareImages;
- {* True if images are shared between processes (it is set to True,
- if its Handle is assigned to given value, which is a handle of
- already existing ImageList object). }
- property Colors : TImageListColors read FColors write SetColors;
- {* Colors used to represent images. }
- property Masked : Boolean read FMasked write SetMasked;
- {* True, if mask is used. It is set to True, if first added image
- is icon, e.g. }
- property ImgWidth : Integer read FImgWidth write SetImgWidth;
- {* Width of every image in list. If change, ImageList is cleared. }
- property ImgHeight : Integer read FImgHeight write SetImgHeight;
- {* Height of every image in list. If change, ImageList is cleared. }
- property Count : Integer read GetCount;
- {* Number of images in list. }
- property AllocBy : Integer read FAllocBy write SetAllocBy;
- {* Allocation factor. Default is 1. Set it to size of ImageList if this
- value is known - to optimize speed of allocation. }
- property BkColor : TColor read GetBkColor write SetBkColor;
- {* Background color. }
- property BlendColor : TColor read FBlendColor write FBlendColor;
- {* Blend color. }
-
- property Bitmap : HBitmap read GetBitmap;
- {* Bitmap, containing all ImageList images (tiled horizontally). }
- property Mask : HBitmap read GetMask;
- {* Monochrome bitmap, containing masks for all images in list (if not
- Masked, always returns nil). }
- function ImgRect( Idx : Integer ) : TRect;
- {* Rectangle occupied of given image in ImageList. }
-
- function Add( Bmp, Msk : HBitmap ) : Integer;
- {* Adds bitmap and given mask to ImageList. }
- function AddMasked( Bmp : HBitmap; Color : TColor ) : Integer;
- {* Adds bitmap to ImageList, using given color to create mask. }
- function AddIcon( Ico : HIcon ) : Integer;
- {* Adds icon to ImageList (always masked). }
- procedure Delete( Idx : Integer );
- {* Deletes given image from ImageList. }
- procedure Clear;
- {* Makes ImageList empty. }
- function Replace( Idx : Integer; Bmp, Msk : HBitmap ) : Boolean;
- {* Replaces given (by index) image with bitmap and its mask with mask bitmap. }
- function ReplaceIcon( Idx : Integer; Ico : HIcon ) : Boolean;
- {* Replaces given (by index) image with an icon. }
- function Merge( Idx : Integer; ImgList2 : PImageList; Idx2 : Integer; X, Y : Integer )
- : PImageList;
- {* Merges two ImageList objects, returns resulting ImageList. }
- function ExtractIcon( Idx : Integer ) : HIcon;
- {* Extracts icon by index. }
- function ExtractIconEx( Idx : Integer ) : HIcon;
- {* Extracts icon (is created using current drawing style). }
-
- property DrawingStyle : TDrawingStyle read FDrawingStyle write FDrawingStyle;
- {* Drawing style. }
- procedure Draw( Idx : Integer; DC : HDC; X, Y : Integer );
- {* Draws given (by index) image from ImageList onto passed Device Context. }
- procedure StretchDraw( Idx : Integer; DC : HDC; const Rect : TRect );
- {* Draws given image with stratching. }
-
- function LoadBitmap( ResourceName : PKOLChar; TranspColor : TColor ) : Boolean;
- {* Loads ImageList from resource. }
- //function LoadIcon( ResourceName : PChar ) : Boolean;
- //function LoadCursor( ResourceName : PChar ) : Boolean;
- function LoadFromFile( FileName : PKOLChar; TranspColor : TColor; ImgType : TImageType ) : Boolean;
- {* Loads ImageList from file. }
- function LoadSystemIcons( SmallIcons : Boolean ) : Boolean;
- {* Assigns ImageList to system icons list (big or small). }
-
- property Overlay[ Idx: TImgLOVrlayIdx ]: Integer read GetOverlay write SetOverlay;
- {* Overlay images for image list (images, used as overlay images to draw over
- other images from the image list). These overalay images can be used in
- listview and treeview as overlaying images (up to four masks at the same
- time). }
- {$IFDEF USE_CONSTRUCTORS}
- constructor CreateImageList( POwner: Pointer );
- {$ENDIF USE_CONSTRUCTORS}
- end;
- //[END OF TImageList DEFINITION]
-
- //[IMAGE LIST API]
- {$ifdef win32}
- const
- CLR_NONE = $FFFFFFFF;
- CLR_DEFAULT = $FF000000;
-
- type
- HImageList = THandle;
-
- const
- ILC_MASK = $0001;
- ILC_COLOR = $00FE;
- ILC_COLORDDB = $00FE;
- ILC_COLOR4 = $0004;
- ILC_COLOR8 = $0008;
- ILC_COLOR16 = $0010;
- ILC_COLOR24 = $0018;
- ILC_COLOR32 = $0020;
- ILC_PALETTE = $0800;
-
- const
- ILD_NORMAL = $0000;
- ILD_TRANSPARENT = $0001;
- ILD_MASK = $0010;
- ILD_IMAGE = $0020;
- ILD_BLEND25 = $0002;
- ILD_BLEND50 = $0004;
- ILD_OVERLAYMASK = $0F00;
-
- const
- ILD_SELECTED = ILD_BLEND50;
- ILD_FOCUS = ILD_BLEND25;
- ILD_BLEND = ILD_BLEND50;
- CLR_HILIGHT = CLR_DEFAULT;
-
- function ImageList_Create(CX, CY: Integer; Flags: UINT;
- Initial, Grow: Integer): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_Destroy(ImageList: HImageList): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_GetImageCount(ImageList: HImageList): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_SetImageCount(ImageList: HImageList; Count: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_Add(ImageList: HImageList; Image, Mask: HBitmap): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_ReplaceIcon(ImageList: HImageList; Index: Integer;
- Icon: HIcon): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_SetBkColor(ImageList: HImageList; ClrBk: TColorRef): TColorRef; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_GetBkColor(ImageList: HImageList): TColorRef; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_SetOverlayImage(ImageList: HImageList; Image: Integer;
- Overlay: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
-
- function Index2OverlayMask(Index: Integer): Integer;
-
- function ImageList_Draw(ImageList: HImageList; Index: Integer;
- Dest: HDC; X, Y: Integer; Style: UINT): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- function ImageList_Replace(ImageList: HImageList; Index: Integer;
- Image, Mask: HBitmap): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_AddMasked(ImageList: HImageList; Image: HBitmap;
- Mask: TColorRef): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_DrawEx(ImageList: HImageList; Index: Integer;
- Dest: HDC; X, Y, DX, DY: Integer; Bk, Fg: TColorRef; Style: Cardinal): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_Remove(ImageList: HImageList; Index: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_GetIcon(ImageList: HImageList; Index: Integer;
- Flags: Cardinal): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$IFDEF UNICODE_CTRLS}
- function ImageList_LoadImage(Instance: THandle; Bmp: PWideChar; CX, Grow: Integer;
- Mask: TColorRef; pType, Flags: Cardinal): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$ELSE}
- function ImageList_LoadImage(Instance: THandle; Bmp: PAnsiChar; CX, Grow: Integer;
- Mask: TColorRef; pType, Flags: Cardinal): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$ENDIF}
- function ImageList_BeginDrag(ImageList: HImageList; Track: Integer;
- XHotSpot, YHotSpot: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_EndDrag: Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_DragEnter(LockWnd: HWnd; X, Y: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_DragLeave(LockWnd: HWnd): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_DragMove(X, Y: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_SetDragCursorImage(ImageList: HImageList; Drag: Integer;
- XHotSpot, YHotSpot: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_DragShowNolock(Show: Bool): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_GetDragImage(Point, HotSpot: PPoint): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- { macros }
- procedure ImageList_RemoveAll(ImageList: HImageList); {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
- Image: Integer): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
- CX, Grow: Integer; MasK: TColorRef): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- //function ImageList_Read(Stream: IStream): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- //function ImageList_Write(ImageList: HImageList; Stream: IStream): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- //[TImageInfo]
- type
- PImageInfo = ^TImageInfo;
- TImageInfo = {$ifndef wince}packed{$endif} record
- hbmImage: HBitmap;
- hbmMask: HBitmap;
- Unused1: Integer;
- Unused2: Integer;
- rcImage: TRect;
- end;
-
- function ImageList_GetIconSize(ImageList: HImageList; var CX, CY: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_SetIconSize(ImageList: HImageList; CX, CY: Integer): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_GetImageInfo(ImageList: HImageList; Index: Integer;
- var ImageInfo: TImageInfo): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- function ImageList_Merge(ImageList1: HImageList; Index1: Integer;
- ImageList2: HImageList; Index2: Integer; DX, DY: Integer)://Bool - ERROR IN VCL
- HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$endif win32}
-
- //[LoadBmp]
- function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
-
- //[BITMAPS]
- type
- tagBitmap = Windows.TBitmap;
-
- TPixelFormat = ( pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit,
- pf32bit, pfCustom );
- {* Available pixel formats. }
- TBitmapHandleType = ( bmDIB, bmDDB );
- {* Available bitmap handle types. }
-
- {++}(*TBitmap = class;*){--}
- PBitmap = {-}^{+}TBitmap;
- { ----------------------------------------------------------------------
- TBitmap - bitmap image
- ----------------------------------------------------------------------- }
- //[TBitmap DEFINITION]
- TBitmap = object( TObj )
- {* Bitmap incapsulation object. }
- protected
- fHeight: Integer;
- fWidth: Integer;
- fHandle: HBitmap;
- fCanvas: PCanvas;
- fScanLineSize: Integer;
- fBkColor: TColor;
- fApplyBkColor2Canvas: procedure( Sender: PBitmap );
- fDetachCanvas: procedure( Sender: PBitmap );
- fCanvasAttached : Integer;
- fHandleType: TBitmapHandleType;
- fDIBHeader: PBitmapInfo;
- fDIBBits: Pointer;
- fDIBSize: Integer;
- fNewPixelFormat: TPixelFormat;
- fFillWithBkColor: procedure( BmpObj: PBitmap; DC: HDC; oldW, oldH: Integer );
- fTransMaskBmp: PBitmap;
- fTransColor: TColor;
- fGetDIBPixels: function( Bmp: PBitmap; X, Y: Integer ): TColor;
- fSetDIBPixels: procedure( Bmp: PBitmap; X, Y: Integer; Value: TColor );
- fScanLine0: PByte;
- fScanLineDelta: Integer;
- fPixelMask: DWORD;
- fPixelsPerByteMask: Integer;
- fBytesPerPixel: Integer;
- fDIBAutoFree: Boolean;
- procedure SetHeight(const Value: Integer);
- procedure SetWidth(const Value: Integer);
- function GetEmpty: Boolean;
- function GetHandle: HBitmap;
- function GetHandleAllocated: Boolean;
- procedure SetHandle(const Value: HBitmap);
- procedure SetPixelFormat(Value: TPixelFormat);
- procedure FormatChanged;
- function GetCanvas: PCanvas;
- procedure CanvasChanged( Sender: PObj );
- function GetScanLine(Y: Integer): Pointer;
- function GetScanLineSize: Integer;
- procedure ClearData;
- procedure ClearTransImage;
- procedure SetBkColor(const Value: TColor);
- function GetDIBPalEntries(Idx: Integer): TColor;
- function GetDIBPalEntryCount: Integer;
- procedure SetDIBPalEntries(Idx: Integer; const Value: TColor);
- procedure SetHandleType(const Value: TBitmapHandleType);
- function GetPixelFormat: TPixelFormat;
- function GetPixels(X, Y: Integer): TColor;
- procedure SetPixels(X, Y: Integer; const Value: TColor);
- function GetDIBPixels(X, Y: Integer): TColor;
- procedure SetDIBPixels(X, Y: Integer; const Value: TColor);
- function GetBoundsRect: TRect;
- protected
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- public
- property Width: Integer read fWidth write SetWidth;
- {* Width of bitmap. To make code smaller, avoid changing Width or Height
- after bitmap is created (using NewBitmap) or after it is loaded from
- file, stream of resource. }
- property Height: Integer read fHeight write SetHeight;
- {* Height of bitmap. To make code smaller, avoid changing Width or Height
- after bitmap is created (using NewBitmap) or after it is loaded from
- file, stream of resource. }
- property BoundsRect: TRect read GetBoundsRect;
- {* Returns rectangle (0,0,Width,Height). }
- property Empty: Boolean read GetEmpty;
- {* Returns True if Width or Height is 0. }
- procedure Clear;
- {* Makes bitmap empty, setting its Width and Height to 0. }
- procedure LoadFromFile( const Filename: KOLString );
- {* Loads bitmap from file (LoadFromStream used). }
- function LoadFromFileEx( const Filename: KOLString ): Boolean;
- {* Loads bitmap from a file. If necessary, bitmap is RLE-decoded. Code given
- by Vyacheslav A. Gavrik. }
- procedure SaveToFile( const Filename: KOLString );
- {* Stores bitmap to file (SaveToStream used). }
- procedure LoadFromStream( Strm: PStream );
- {* Loads bitmap from stream. Follow loading, bitmap has DIB format (without
- handle allocated). It is possible to draw DIB bitmap without creating
- handle for it, which can economy GDI resources. }
- function LoadFromStreamEx( Strm: PStream ): Boolean;
- {* Loads bitmap from a stream. Difference is that RLE decoding supported.
- Code given by Vyacheslav A. Gavrik. }
- procedure SaveToStream( Strm: PStream );
- {* Saves bitmap to stream. If bitmap is not DIB, it is converted to DIB
- before saving. }
- procedure LoadFromResourceID( Inst: DWORD; ResID: Integer );
- {* Loads bitmap from resource using integer ID of resource. To load by name,
- use LoadFromResurceName. To load resource of application itself, pass
- hInstance as first parameter. This method also can be used to load system
- predefined bitmaps, if 0 is passed as Inst parameter:
- |<pre>
- OBM_BTNCORNERS OBM_REDUCE
- OBM_BTSIZE OBM_REDUCED
- OBM_CHECK OBM_RESTORE
- OBM_CHECKBOXES OBM_RESTORED
- OBM_CLOSE OBM_RGARROW
- OBM_COMBO OBM_RGARROWD
- OBM_DNARROW OBM_RGARROWI
- OBM_DNARROWD OBM_SIZE
- OBM_DNARROWI OBM_UPARROW
- OBM_LFARROW OBM_UPARROWD
- OBM_LFARROWD OBM_UPARROWI
- OBM_LFARROWI OBM_ZOOM
- OBM_MNARROW OBM_ZOOMD
- |</pre> }
- procedure LoadFromResourceName( Inst: DWORD; ResName: PKOLChar );
- {* Loads bitmap from resurce (using passed name of bitmap resource. }
- function Assign( SrcBmp: PBitmap ): Boolean;
- {* Assigns bitmap from another. Returns False if not success.
- Note: remember, that Canvas is not assigned - only bitmap image
- is copied. And for DIB, handle is not allocating due this process. }
- property Handle: HBitmap read GetHandle write SetHandle;
- {* Handle of bitmap. Created whenever property accessed. To check if handle
- is allocated (without allocating it), use HandleAllocated property. }
- property HandleAllocated: Boolean read GetHandleAllocated;
- {* Returns True, if Handle already allocated. }
- function ReleaseHandle: HBitmap;
- {* Returns Handle and releases it, so bitmap no more know about handle.
- This method does not destroy bitmap image, but converts it into DIB.
- Returned Handle actually is a handle of copy of original bitmap. If
- You need not in keping it up, use Dormant method instead. }
- procedure Dormant;
- {* Releases handle from bitmap and destroys it. But image is not destroyed
- and its data are preserved in DIB format. Please note, that in KOL, DIB
- bitmaps can be drawn onto given device context without allocating of
- handle. So, it is very useful to call Dormant preparing it using
- Canvas drawing operations - to economy GDI resources. }
- property HandleType: TBitmapHandleType read fHandleType write SetHandleType;
- {* bmDIB, if DIB part of image data is filled and stored internally in
- TBitmap object. DIB image therefore can have Handle allocated, which
- require resources. Use HandleAllocated funtion to determine if handle
- is allocated and Dormant method to remove it, if You want to economy
- GDI resources. (Actually Handle needed for DIB bitmap only in case
- when Canvas is used to draw on bitmap surface). Please note also, that
- before saving bitmap to file or stream, it is converted to DIB. }
- property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
- {* Current pixel format. If format of bitmap is unknown, or bitmap is DDB,
- value is pfDevice. Setting PixelFormat to any other format converts
- bitmap to DIB, back to pfDevice converts bitmap to DDB again. Avoid
- such conversations for large bitmaps or for numerous bitmaps in your
- application to keep good performance. }
- function BitsPerPixel: Integer;
- {* Returns bits per pixel if possible. }
- procedure Draw( DC: HDC; X, Y: Integer );
- {* Draws bitmap to given device context. If bitmap is DIB, it is always
- drawing using SetDIBitsToDevice API call, which does not require bitmap
- handle (so, it is very sensible to call Dormant method to free correspondent
- GDI resources). }
- procedure StretchDraw( DC: HDC; const Rect: TRect );
- {* Draws bitmap onto DC, stretching it to fit given rectangle Rect. }
- procedure DrawTransparent( DC: HDC; X, Y: Integer; TranspColor: TColor );
- {* Draws bitmap onto DC transparently, using TranspColor as transparent.
- See function DesktopPixelFormat also. }
- procedure StretchDrawTransparent( DC: HDC; const Rect: TRect; TranspColor: TColor );
- {* Draws bitmap onto given rectangle of destination DC (with stretching it
- to fit Rect) - transparently, using TranspColor as transparent.
- See function DesktopPixelFormat also. }
- procedure DrawMasked( DC: HDC; X, Y: Integer; Mask: HBitmap );
- {* Draws bitmap to destination DC transparently by mask. It is possible
- to pass as a mask handle of another TBitmap, previously converted to
- monochrome mask using Convert2Mask method. }
- procedure StretchDrawMasked( DC: HDC; const Rect: TRect; Mask: HBitmap );
- {* Like DrawMasked, but with stretching image onto given rectangle. }
- procedure Convert2Mask( TranspColor: TColor );
- {* Converts bitmap to monochrome (mask) bitmap with TranspColor replaced
- to clBlack and all other ones to clWhite. Such mask bitmap can be used
- to draw original bitmap transparently, with given TranspColor as
- transparent. (To preserve original bitmap, create new instance of
- TBitmap and assign original bitmap to it). See also DrawTransparent and
- StretchDrawTransparent methods. }
- procedure Invert;
- {* Obvious. }
- property Canvas: PCanvas read GetCanvas;
- {* Canvas can be used to draw onto bitmap. Whenever it is accessed, handle
- is allocated for bitmap, if it is not yet (to make it possible
- to select bitmap to display compatible device context). }
- procedure RemoveCanvas;
- {* Call this method to destroy Canvas and free GDI resources. }
- property BkColor: TColor read fBkColor write SetBkColor;
- {* Used to fill background for Bitmap, when its width or height is increased.
- Although this value always synchronized with Canvas.Brush.Color, use it
- instead if You do not use Canvas for drawing on bitmap surface. }
- property Pixels[ X, Y: Integer ]: TColor read GetPixels write SetPixels;
- {* Allows to obtain or change certain pixels of a bitmap. This method is
- both for DIB and DDB bitmaps, and leads to allocate handle anyway. For
- DIB bitmaps, it is possible to use property DIBPixels[ ] instead,
- which is much faster and does not require in Handle. }
- property ScanLineSize: Integer read GetScanLineSize;
- {* Returns size of scan line in bytes. Use it to measure size of a single
- ScanLine. To calculate increment value from first byte of ScanLine to
- first byte of next ScanLine, use difference
- ! Integer(ScanLine[1]-ScanLine[0])
- (this is because bitmap can be oriented from bottom to top, so
- step can be negative). }
- property ScanLine[ Y: Integer ]: Pointer read GetScanLine;
- {* Use ScanLine to access DIB bitmap pixels in memory to direct access it
- fast. Take in attention, that for different pixel formats, different
- bit counts are used to represent bitmap pixels. Also do not forget, that
- for formats pf4bit and pf8bit, pixels actually are indices to palette
- entries, and for formats pf16bit, pf24bit and pf32bit are actually
- RGB values (for pf16bit B:5-G:6-R:5, for pf15bit B:5-G:5-R:5 (high order
- bit not used), for pf24bit B:8-G:8-R:8, and for pf32bit high order byte
- of TRGBQuad structure is not used). }
- property DIBPixels[ X, Y: Integer ]: TColor read GetDIBPixels write SetDIBPixels;
- {* Allows direct access to pixels of DIB bitmap, faster then Pixels[ ]
- property. Access to read is slower for pf15bit, pf16bit formats (because
- some conversation needed to translate packed RGB color to TColor). And
- for write, operation performed most slower for pf4bit, pf8bit (searching
- nearest color required) and fastest for pf24bit, pf32bit and pf1bit. }
- property DIBPalEntryCount: Integer read GetDIBPalEntryCount;
- {* Returns palette entries count for DIB image. Always returns 2 for pf1bit,
- 16 for pf4bit, 256 for pf8bit and 0 for other pixel formats. }
- property DIBPalEntries[ Idx: Integer ]: TColor read GetDIBPalEntries write
- SetDIBPalEntries;
- {* Provides direct access to DIB palette. }
- function DIBPalNearestEntry( Color: TColor ): Integer;
- {* Returns index of entry in DIB palette with color nearest (or matching)
- to given one. }
- property DIBBits: Pointer read fDIBBits;
- {* This property is mainly for internal use. }
- property DIBSize: Integer read fDIBSize;
- {* Size of DIBBits array. }
- property DIBHeader: PBitmapInfo read fDIBHeader;
- {* This property is mainly for internal use. }
- procedure DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
- {* This procedure copies given rectangle to the target device context,
- but only for DIB bitmap (using SetDIBBitsToDevice API call). }
- procedure RotateRight;
- {* Rotates bitmap right (90 degree). Bitmap must be DIB. If You definitevely
- know format of a bitmap, use instead one of methods RotateRightMono,
- RotateRight4bit, RotateRight8bit, RotateRight16bit or RotateRightTrueColor
- - this will economy code. But if for most of formats such methods are
- called, this can be more economy just to call always universal method
- RotateRight. }
- procedure RotateLeft;
- {* Rotates bitmap left (90 degree). Bitmap must be DIB. If You definitevely
- know format of a bitmap, use instead one of methods RotateLeftMono,
- RotateLeft4bit, RotateLeft8bit, RotateLeft16bit or RotateLeftTrueColor
- - this will economy code. But if for most of formats such methods are
- called, this can be more economy just to call always universal method
- RotateLeft. }
- procedure RotateRightMono;
- {* Rotates bitmat right, but only if bitmap is monochrome (pf1bit). }
- procedure RotateLeftMono;
- {* Rotates bitmap left, but only if bitmap is monochrome (pf1bit). }
- procedure RotateRight4bit;
- {* Rotates bitmap right, but only if PixelFormat is pf4bit. }
- procedure RotateLeft4bit;
- {* Rotates bitmap left, but only if PixelFormat is pf4bit. }
- procedure RotateRight8bit;
- {* Rotates bitmap right, but only if PixelFormat is pf8bit. }
- procedure RotateLeft8bit;
- {* Rotates bitmap left, but only if PixelFormat is pf8bit. }
- procedure RotateRight16bit;
- {* Rotates bitmap right, but only if PixelFormat is pf16bit. }
- procedure RotateLeft16bit;
- {* Rotates bitmap left, but only if PixelFormat is pf16bit. }
- procedure RotateRightTrueColor;
- {* Rotates bitmap right, but only if PixelFormat is pf24bit or pf32bit. }
- procedure RotateLeftTrueColor;
- {* Rotates bitmap left, but only if PixelFormat is pf24bit or pf32bit. }
- procedure FlipVertical;
- {* Flips bitmap vertically }
- procedure FlipHorizontal;
- {* Flips bitmap horizontally }
- procedure CopyRect( const DstRect : TRect; SrcBmp : PBitmap; const SrcRect : TRect );
- {* It is possible to use Canvas.CopyRect for such purpose, but if You
- do not want use TCanvas, it is possible to copy rectangle from one
- bitmap to another using this function. }
- function CopyToClipboard: Boolean;
- {* Copies bitmap to clipboard. }
- function PasteFromClipboard: Boolean;
- {* Takes CF_DIB format bitmap from clipboard and assigns it to the
- TBitmap object. }
- end;
- //[END OF TBitmap DEFINITION]
-
- //
- function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
-
- //[NewBitmap DECLARATION]
- function NewBitmap( W, H: Integer ): PBitmap;
- {* Creates bitmap object of given size. If it is possible, do not change its
- size (Width and Heigth) later - this can economy code a bit. See TBitmap. }
-
- function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
- {* Creates DIB bitmap object of given size and pixel format. If it is possible,
- do not change its size (Width and Heigth) later - this can economy code a bit.
- See TBitmap. }
-
- //[CalcScanLineSize DECLARATION]
- function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
- {* May be will be useful. }
-
- //[DefaultPixelFormat VARIABLE]
- var
- //DefaultBitsPerPixel: Integer = 16;
- DefaultPixelFormat: TPixelFormat = pf16bit;
-
- //[Mapped bitmaps]
- { -- Function to load bitmap mapping some its colors. -- }
- function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
- : HBitmap;
- {* This function can be used to load bitmap and replace some it colors to
- desired ones. This function especially useful when loaded by the such way
- bitmap is used as toolbar bitmap - to replace some original colors to
- system default colors. To use this function properly, the bitmap shoud
- be prepared as 16-color bitmap, which uses only system colors. To do so,
- create a new 16-color bitmap with needed dimensions in Borland Image Editor
- and paste a bitmap image, copyed in another graphic tool, and then save it.
- If this is not done, bitmap will not be loaded correctly! }
- function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar;
- const Map: array of TColor ): HBitmap;
- {* by Alex Pravdin: like LoadMappedBitmap, but much powerful. It uses
- CreateMappedBitmapEx, so it understands any bitmap color format, including
- pf24bit. Also, LoadMappedBitmapEx provides auto-destroying loaded resource
- when MasterObj is destroyed. }
- function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
- Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Creates mapped bitmap replacing colors correspondently to the
- ColorMap (each pare of colors defines color replaced and a color
- used for replace it in the bitmap). See also CreateMappedBitmapEx. }
- function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
- Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
- {* By Alex Pravdin.
- Creates mapped bitmap independently from bitmap color format (works
- correctly with bitmaps having format deeper than 8bit per pixel). }
-
- //[ICONS]
-
- type
- {++}(*TIcon = class;*){--}
- PIcon = {-}^{+}TIcon;
- { ----------------------------------------------------------------------
- TIcon - icon image
- ----------------------------------------------------------------------- }
- //[TIcon DEFINITION]
- TIcon = object( TObj )
- {* Object type to incapsulate icon or cursor image. }
- protected
- {$IFDEF ICON_DIFF_WH}
- FWidth: Integer;
- FHeight: Integer;
- {$ELSE}
- FSize : Integer;
- {$ENDIF}
- FHandle: HIcon;
- FShareIcon: Boolean;
- procedure SetSize(const Value: Integer);
- {$IFDEF ICON_DIFF_WH}
- function GetIconSize: Integer;
- {$ENDIF}
- procedure SetHandle(const Value: HIcon);
- function GetHotSpot: TPoint;
- function GetEmpty: Boolean;
- protected
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- public
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- ImgBmp, MskBmp : PBitmap;
- Only_Bmp: Boolean;
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- property Size : Integer read
- {$IFDEF ICON_DIFF_WH}
- GetIconSize
- {$ELSE}
- FSize
- {$ENDIF}
- write SetSize;
- {* Icon dimension (width and/or height, which are equal to each other always). }
- {$IFDEF ICON_DIFF_WH}
- property Width: Integer read FWidth;
- property Height: Integer read FHeight;
- {$ENDIF}
- property Handle : HIcon read FHandle write SetHandle;
- {* Windows icon object handle. }
- procedure Clear;
- {* Clears icon, freeing image and allocated GDI resource (Handle). }
- property Empty: Boolean read GetEmpty;
- {* Returns True if icon is Empty. }
- property ShareIcon : Boolean read FShareIcon write FShareIcon;
- {* True, if icon object is shared and can not be deleted when TIcon object
- is destroyed (set this flag is to True, if an icon is obtained from another
- TIcon object, for example). }
- property HotSpot : TPoint read GetHotSpot;
- {* Hot spot point - for cursors. }
- procedure Draw( DC : HDC; X, Y : Integer );
- {* Draws icon onto given device context. Icon always is drawn transparently
- using its transparency mask (stored internally in icon object). }
- procedure StretchDraw( DC : HDC; Dest : TRect );
- {* Draws icon onto given device context with stretching it to fit destination
- rectangle. See also Draw. }
- procedure LoadFromStream( Strm : PStream );
- {* Loads icon from stream. If stream contains several icons (of
- different dimentions), icon with the most appropriate size is loading. }
- procedure LoadFromFile( const FileName : KOLString );
- {* Load icon from file. If file contains several icons (of
- different dimensions), icon with the most appropriate size is loading. }
- procedure LoadFromResourceID( Inst: Integer; ResID: Integer; DesiredSize: Integer );
- {* Loads icon from resource. To load system default icon, pass 0 as Inst and
- one of followin values as ResID:
- |<pre>
- IDI_APPLICATION Default application icon.
- IDI_ASTERISK Asterisk (used in informative messages).
- IDI_EXCLAMATION Exclamation point (used in warning messages).
- IDI_HAND Hand-shaped icon (used in serious warning messages).
- IDI_QUESTION Question mark (used in prompting messages).
- IDI_WINLOGO Windows logo.
- |</pre> It is also possible to load icon from resources of another module,
- if pass instance handle of loaded module as Inst parameter. }
- procedure LoadFromResourceName( Inst: Integer; ResName: PKOLChar; DesiredSize: Integer );
- {* Loads icon from resource. To load own application resource, pass
- hInstance as Inst parameter. It is possible to load resource from
- another module, if pass its instance handle as Inst. }
- procedure LoadFromExecutable( const FileName: KOLString; IconIdx: Integer );
- {* Loads icon from executable (exe or dll file). Always default sized icon
- is loaded. It is possible also to get know how much icons are contained
- in executable using gloabl function GetFileIconCount. To obtain icon of
- another size, try to load given executable and use LoadFromResourceID
- method. }
- {$ifdef win32}
- procedure SaveToStream( Strm : PStream );
- {* Saves single icon to stream. To save icons with several different
- dimensions, use global procedure SaveIcons2Stream. }
- procedure SaveToFile( const FileName : KOLString );
- {* Saves single icon to file. To save icons with several different
- dimensions, use global procedure SaveIcons2File. }
- {$endif win32}
- function Convert2Bitmap( TranColor: TColor ): HBitmap;
- {* Converts icon to bitmap, returning Windows GDI bitmap resource as
- a result. It is possible later to assign returned bitmap handle to
- Handle property of TBitmap object to use features of TBitmap.
- Pass TranColor to replace transparent area of icon with given color. }
- end;
- //[END OF TIcon DEFINITION]
-
- //[Icon save functions]
- {$ifdef win32}
- procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
- {* Saves several icons (of different dimentions) to stream. }
- function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
- {* Saves icons creating it from pairs of bitmaps and their masks.
- BmpHandles array must contain pairs of bitmap handles, each pair
- of color bitmap and mask bitmap of the same size. }
- procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
- {* Saves several icons (of different dimentions) to file. (Single file
- with extension .ico can contain several different sized icon images
- to use later one with the most appropriate size). }
- {$endif win32}
- //[NewIcon DECLARATION]
- function NewIcon: PIcon;
- {* Creates new icon object, setting its Size to 32 by default. Created icon
- is Empty. }
-
- //[GetFileIconCount DECLARATION]
- function GetFileIconCount( const FileName: KOLString ): Integer;
- {* Returns number of icon resources stored in given (executable) file. }
-
- //[ICON STRUCTURES]
- type
- TIconHeader = packed record
- idReserved: Word; (* Always set to 0 *)
- idType: Word; (* Always set to 1 *)
- idCount: Word; (* Number of icon images *)
- (* immediately followed by idCount TIconDirEntries *)
- end;
-
- TIconDirEntry = packed record
- bWidth: Byte; (* Width *)
- bHeight: Byte; (* Height *)
- bColorCount: Byte; (* Nr. of colors used *)
- bReserved: Byte; (* not used, 0 *)
- wPlanes: Word; (* not used, 0 *)
- wBitCount: Word; (* not used, 0 *)
- dwBytesInRes: Longint; (* total number of bytes in images *)
- dwImageOffset: Longint;(* location of image from the beginning of file *)
- end;
-
- //[LoadImgIcon DECLARATION]
- function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
- {* Loads icon of specified size from the resource. }
-
- ////////////////////////////////////////////////////////////////////////////////
- // UNIVERSAL CONTROL OBJECT //
- ////////////////////////////////////////////////////////////////////////////////
-
- //[CM_XXX CONSTANTS]
-
- const
- CM_EXECPROC = $8FFF;
- CM_BASE = $B000;
- CM_ACTIVATE = CM_BASE + 0;
- CM_DEACTIVATE = CM_BASE + 1;
- CM_ENTER = CM_BASE + 2;
- CM_RELEASE = CM_BASE + 3;
- CM_QUIT = CM_BASE + 4;
- CM_COMMAND = CM_BASE + 5;
- CM_MEASUREITEM = CM_BASE + 6;
- CM_DRAWITEM = CM_BASE + 7;
- CM_TRAYICON = CM_BASE + 8;
- CM_INVALIDATE = CM_BASE + 9;
- CM_UPDATE = CM_BASE + 10;
- CM_NCUPDATE = CM_BASE + 11;
- CM_SIZEPOS = CM_BASE + 12;
- CM_SIZE = CM_BASE + 13;
- CM_SETFOCUS = CM_BASE + 14;
- CM_CBN_SELCHANGE = 15;
-
- CM_UIACTIVATE = CM_BASE + 16;
- CM_UIDEACTIVATE = CM_BASE + 17;
- CM_PROCESS = CM_BASE + 18;
- CM_SHOW = CM_BASE + 19;
-
- CM_AUTOSIZE = CM_BASE + 20;
- CM_MDIClientShowEdge = CM_BASE + 21;
-
- CM_INVALIDATECHILD = CM_BASE + 22;
- CM_FOCUSGRAPHCTL = CM_BASE + 23;
-
- WM_SYNCPAINT = $88;
-
- //[CN_XXX CONSTANTS]
-
- CN_BASE = $BC00;
- CN_CHARTOITEM = CN_BASE + WM_CHARTOITEM;
- CN_COMMAND = CN_BASE + WM_COMMAND;
- CN_COMPAREITEM = CN_BASE + WM_COMPAREITEM;
-
- CN_CTLCOLORMSGBOX = CN_BASE + WM_CTLCOLORMSGBOX;
- CN_CTLCOLOREDIT = CN_BASE + WM_CTLCOLOREDIT;
- CN_CTLCOLORLISTBOX = CN_BASE + WM_CTLCOLORLISTBOX;
- CN_CTLCOLORBTN = CN_BASE + WM_CTLCOLORBTN;
- CN_CTLCOLORDLG = CN_BASE + WM_CTLCOLORDLG;
- CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;
- CN_CTLCOLORSTATIC = CN_BASE + WM_CTLCOLORSTATIC;
-
- CN_DELETEITEM = CN_BASE + WM_DELETEITEM;
- CN_DRAWITEM = CN_BASE + WM_DRAWITEM;
- CN_HSCROLL = CN_BASE + WM_HSCROLL;
- CN_MEASUREITEM = CN_BASE + WM_MEASUREITEM;
- CN_PARENTNOTIFY = CN_BASE + WM_PARENTNOTIFY;
- CN_VKEYTOITEM = CN_BASE + WM_VKEYTOITEM;
- CN_VSCROLL = CN_BASE + WM_VSCROLL;
- CN_KEYDOWN = CN_BASE + WM_KEYDOWN;
- CN_KEYUP = CN_BASE + WM_KEYUP;
- CN_CHAR = CN_BASE + WM_CHAR;
- CN_SYSKEYDOWN = CN_BASE + WM_SYSKEYDOWN;
- CN_SYSCHAR = CN_BASE + WM_SYSCHAR;
- CN_NOTIFY = CN_BASE + WM_NOTIFY;
-
- {$ENDIF WIN_GDI}
- //[ID_SELF DEFINED]
- const
- ID_SELF: array[ 0..5 ] of KOLChar = ( 'S','E','L','F','_',#0 );
- {* Identifier for window property "Self", stored directly in window, when
- it is created. This property is used to [fast] find TControl object,
- correspondent to given window handle (using API call GetProp). }
- {$IFDEF WIN_GDI}
-
- //[ID_PREVPROC DEFINED]
- ID_PREVPROC: array[ 0..9 ] of KOLChar = ( 'P','R','E','V','_','P','R','O','C',#0 );
- {* }
-
- {$ENDIF WIN_GDI}
- //[MK_ALT DEFINED]
- const
- MK_LBUTTON = 1;
- MK_RBUTTON = 2;
- MK_SHIFT = 4;
- MK_CONTROL = 8;
- MK_MBUTTON = $10;
- MK_ALT = $20;
- MK_LOCK = $40; // CAPS LOCK or SHIFT LOCK
- {$IFDEF WIN_GDI}
-
- {$IFNDEF NOT_USE_RICHEDIT}
- //[RICHEDIT STRUCTURES]
- type
- TCharFormat2 = {$ifndef wince}packed{$endif} record
- cbSize: UINT;
- dwMask: DWORD;
- dwEffects: DWORD;
- yHeight: Longint;
- yOffset: Longint;
- crTextColor: TColorRef;
- bCharSet: Byte;
- bPitchAndFamily: Byte;
- szFaceName: array[0..LF_FACESIZE - 1] of KOLChar;
- R2Bytes: Word;
- wWeight: Word; { Font weight (LOGFONT value) }
- sSpacing: Smallint; { Amount to space between letters }
- crBackColor: TColorRef; { Background color }
- lid: LCID; { Locale ID }
- dwReserved: DWORD; { Reserved. Must be 0 }
- sStyle: Smallint; { Style handle }
- wKerning: Word; { Twip size above which to kern char pair }
- bUnderlineType: Byte; { Underline type }
- bAnimation: Byte; { Animated text like marching ants }
- bRevAuthor: Byte; { Revision author index }
- bReserved1: Byte;
- end;
- //TCharFormat2 = TCharFormat2A;
-
- TParaFormat2 = {$ifndef wince}packed{$endif} record
- cbSize: UINT;
- dwMask: DWORD;
- wNumbering: Word;
- wReserved: Word;
- dxStartIndent: Longint;
- dxRightIndent: Longint;
- dxOffset: Longint;
- wAlignment: Word;
- cTabCount: Smallint;
- rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;
- dySpaceBefore: Longint; { Vertical spacing before para }
- dySpaceAfter: Longint; { Vertical spacing after para }
- dyLineSpacing: Longint; { Line spacing depending on Rule }
- sStyle: Smallint; { Style handle }
- bLineSpacingRule: Byte; { Rule for line spacing (see tom.doc) }
- bCRC: Byte; { Reserved for CRC for rapid searching }
- wShadingWeight: Word; { Shading in hundredths of a per cent }
- wShadingStyle: Word; { Nibble 0: style, 1: cfpat, 2: cbpat }
- wNumberingStart: Word; { Starting value for numbering }
- wNumberingStyle: Word; { Alignment, roman/arabic, (), ), ., etc. }
- wNumberingTab: Word; { Space bet 1st indent and 1st-line text }
- wBorderSpace: Word; { Space between border and text (twips) }
- wBorderWidth: Word; { Border pen width (twips) }
- wBorders: Word; { Byte 0: bits specify which borders }
- { Nibble 2: border style, 3: color index }
- end;
-
- TGetTextLengthEx = {$ifndef wince}packed{$endif} record
- flags: DWORD; { flags (see GTL_XXX defines) }
- codepage: UINT; { code page for translation (CP_ACP for default,
- 1200 for Unicode }
- end;
-
- const
- PFM_SPACEBEFORE = $00000040;
- PFM_SPACEAFTER = $00000080;
- PFM_LINESPACING = $00000100;
- PFM_STYLE = $00000400;
- PFM_BORDER = $00000800; { (*) }
- PFM_SHADING = $00001000; { (*) }
- PFM_NUMBERINGSTYLE = $00002000; { (*) }
- PFM_NUMBERINGTAB = $00004000; { (*) }
- PFM_NUMBERINGSTART = $00008000; { (*) }
-
- PFM_RTLPARA = $00010000;
- PFM_KEEP = $00020000; { (*) }
- PFM_KEEPNEXT = $00040000; { (*) }
- PFM_PAGEBREAKBEFORE = $00080000; { (*) }
- PFM_NOLINENUMBER = $00100000; { (*) }
- PFM_NOWIDOWCONTROL = $00200000; { (*) }
- PFM_DONOTHYPHEN = $00400000; { (*) }
- PFM_SIDEBYSIDE = $00800000; { (*) }
-
- PFM_TABLE = $c0000000; { (*) }
- EM_REDO = WM_USER + 84;
- EM_AUTOURLDETECT = WM_USER + 91;
- EM_GETAUTOURLDETECT = WM_USER + 92;
- CFM_UNDERLINETYPE = $00800000; { (*) }
- CFM_HIDDEN = $0100; { (*) }
- CFM_BACKCOLOR = $04000000;
- CFE_AUTOBACKCOLOR = CFM_BACKCOLOR;
- GTL_USECRLF = 1; { compute answer using CRLFs for paragraphs }
- GTL_PRECISE = 2; { compute a precise answer }
- GTL_CLOSE = 4; { fast computation of a "close" answer }
- GTL_NUMCHARS = 8; { return the number of characters }
- GTL_NUMBYTES = 16; { return the number of _bytes_ }
- EM_GETTEXTLENGTHEX = WM_USER + 95;
- EM_SETLANGOPTIONS = WM_USER + 120;
- EM_GETLANGOPTIONS = WM_USER + 121;
-
- EM_SETEDITSTYLE = $400 + 204;
- EM_GETEDITSTYLE = $400 + 205;
-
- SES_EMULATESYSEDIT = 1;
- SES_BEEPONMAXTEXT = 2;
- SES_EXTENDBACKCOLOR = 4;
- SES_MAPCPS = 8;
- SES_EMULATE10 = 16;
- SES_USECRLF = 32;
- SES_USEAIMM = 64;
- SES_NOIME = 128;
- SES_ALLOWBEEPS = 256;
- SES_UPPERCASE = 512;
- SES_LOWERCASE = 1024;
- SES_NOINPUTSEQUENCECHK = 2048;
- SES_BIDI = 4096;
- SES_SCROLLONKILLFOCUS = 8192;
- SES_XLTCRCRLFTOCR = 16384;
-
- EM_GETSCROLLPOS = WM_USER + 221;
- EM_SETSCROLLPOS = WM_USER + 222;
- EM_GETZOOM = WM_USER + 224;
- EM_SETZOOM = WM_USER + 225;
- {$ENDIF NOT_USE_RICHEDIT}
- {$ENDIF WIN_GDI}
-
- //[CONTROLS]
-
- type
- {++}(*TControl = class;*){--}
- PControl = {-}^{+}TControl;
- {* Type of pointer to TControl visual object. All
- |<a href="kol_pas.htm#visual_objects_constructors">
- constructing functions
- |</a>
- New[ControlName] are returning
- pointer of this type. Do not forget about some difference
- of using objects from using classes. Identifier Self for
- methods of object is not of pointer type, and to pass
- pointer to Self, it is necessary to pass @Self instead.
- At the same time, to use pointer to object in 'WITH' operator,
- it is necessary to apply suffix '^' to pointer to get know
- to compiler, what do You want. }
-
- {$IFDEF WIN}
- //[TWindowFunc TYPE]
- TWindowFunc = function( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- {$ENDIF WIN}
- {* Event type to define custom extended message handlers (as pointers to
- procedure entry points). Such handlers are usually defined like add-ons,
- extending behaviour of certain controls and attached using AttachProc
- method of TControl. If the handler detects, that it is necessary to stop
- further message processing, it should return True. }
-
- //[Mouse TYPES]
- TMouseButton = ( mbNone, mbLeft, mbRight, mbMiddle );
- {* Available mouse buttons. mbNone is useful to get know, that
- there were no mouse buttons pressed. }
-
- TMouseEventData = {$ifndef wince}packed{$endif} Record
- {* Record to pass it to mouse handling routines, assigned to OnMouseXXXX
- events. }
- Button: TMouseButton;
- StopHandling: Boolean; // Set it to True in OnMouseXXXX event handler to
- // stop further processing
- R1, R2: Byte; // Not used
- Shift : DWORD; // HiWord( Shift ) = zDelta in WM_MOUSEWHEEL
- X, Y : SmallInt;
- end;
-
- TOnMouse = procedure( Sender: PControl; var Mouse: TMouseEventData ) of object;
- {* Common mouse handling event type. }
-
- //[Key TYPES]
- TOnKey = procedure( Sender: PControl; var Key: Longint; Shift: DWORD ) of object;
- {* Key events. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT.
- (See GetShiftState funtion). }
-
- TOnChar = procedure( Sender: PControl; var Key: KOLChar; Shift: DWORD ) of object;
- {* Char event. Shift is a combination of flags MK_SHIFT, MK_CONTROL, MK_ALT. }
-
- TTabKey = ( tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn );
- {* Available tabulating key groups. }
- TTabKeys = Set of TTabKey;
- {* Set of tabulating key groups, allowed to be used in with a control
- (are installed by TControl.LookTabKey property). }
-
- //[Event TYPES]
- {$IFDEF WIN}
- TOnMessage = function( var Msg: TMsg; var Rslt: Integer ): Boolean of object;
- {* Event type for events, which allows to extend behaviour of windowed controls
- descendants using add-ons. }
- {$ENDIF WIN}
-
- TOnEventAccept = procedure( Sender: PObj; var Accept: Boolean ) of object;
- {* Event type for OnClose event. }
- TCloseQueryReason = ( qClose, qShutdown, qLogoff );
- {* Request reason type to call OnClose and OnQueryEndSession. }
- TWindowState = ( wsNormal, wsMinimized, wsMaximized );
- {* Avalable states of TControl's window object. }
-
- TOnSplit = function( Sender: PControl; NewSize1, NewSize2: Integer ): Boolean of object;
- {* Event type for OnSplit event handler, designed specially for splitter
- control. Event handler must return True to accept new size of previous
- (to splitter) control and new size of the rest of client area of parent. }
-
- TOnTVBeginDrag = procedure( Sender: PControl; Item: THandle ) of object;
- {* Event type for OnTVBeginDrag event (defined for tree view control). }
- TOnTVBeginEdit = function( Sender: PControl; Item: THandle ): Boolean of object;
- {* Event type for OnTVBeginEdit event (for tree view control). }
- TOnTVEndEdit = function( Sender: PControl; Item: THandle; const NewTxt: KOL_String )
- : Boolean of object;
- {* Event type for TOnTVEndEdit event. }
- TOnTVExpanding = function( Sender: PControl; Item: THandle; Expand: Boolean )
- : Boolean of object;
- {* Event type for TOnTVExpanding event. }
- TOnTVExpanded = procedure( Sender: PControl; Item: THandle; Expand: Boolean )
- of object;
- {* Event type for OnTVExpanded event. }
- TOnTVDelete = procedure( Sender: PControl; Item: THandle ) of object;
- {* Event type for OnTVDelete event. }
-
- //--------- by Sergey Shisminzev:
- TOnTVSelChanging = function(Sender: PControl; oldItem, newItem: THandle): Boolean //~ss
- of object;
- {* When the handler returns False, selection is not changed. }
- //-------------------------------
- TOnDrag = function( Sender: PControl; ScrX, ScrY: Integer; var CursorShape: Integer;
- var Stop: Boolean ): Boolean of object;
- {* Event, called during dragging operation (it is initiated
- with method Drag, where callback function of type TOnDrag is
- passed as a parameter). Callback function receives Stop parameter True,
- when operation is finishing. Otherwise, it can set it to True to force
- finishing the operation (in such case, returning False means cancelling
- drag operation, True - successful drag and in this last case callback is
- no more called). During the operation, when input Stop value is False,
- callback function can control Cursor shape, and return True, if the operation
- can be finished successfully at the given ScrX, ScrY position.
- ScrX, ScrY are screen coordinates of the mouse cursor. }
-
- {$IFDEF WIN}
- //[Create Window STRUCTURES]
- TCreateParams = {$ifndef wince}packed{$endif} record
- {* Record to pass it through CreateSubClass method. }
- Caption: PKOLChar;
- Style: cardinal;
- ExStyle: cardinal;
- X, Y: Integer;
- Width, Height: Integer;
- WndParent: HWnd;
- Param: Pointer;
- WindowClass: TWndClass;
- WinClassName: array[0..63] of KOLChar;
- end;
-
- TCreateWndParams = {$ifndef wince}packed{$endif} Record
- ExStyle: DWORD;
- WinClassName: PKOLChar;
- Caption: PKOLChar;
- Style: DWORD;
- X, Y, Width, Height: Integer;
- WndParent: HWnd;
- Menu: HMenu;
- Inst: THandle;
- Param: Pointer;
- WinClsNamBuf: array[ 0..63 ] of KOLChar;
- WindowClass: TWndClass;
- end;
-
- //[COMMAND ACTIONS TYPE FOR DIFFERENT CONTROLS]
- PCommandActions = ^TCommandActions;
- TCommandActions = {$ifndef wince}packed{$endif} Record
- aClear: procedure( Sender: PControl );
- aAddText: procedure( Sender: PControl; const S: String );
- aClick, aEnter, aLeave: WORD; aChange: SmallInt; aSelChange: SmallInt;
- aGetCount, aSetCount, aGetItemLength, aGetItemText, aSetItemText,
- aGetItemData, aSetItemData: WORD;
- aAddItem, aDeleteItem, aInsertItem: WORD;
- aFindItem, aFindPartial: WORD;
- aItem2Pos, aPos2Item: BYTE;
- {aGetSelStart,} aGetSelCount, aGetSelected, aGetSelRange,
- {aExGetSelRange,} aGetCurrent,
- aSetSelected, aSetCurrent, aSetSelRange, aExSetSelRange,
- aGetSelection, aReplaceSel: WORD;
- aTextAlignLeft, aTextAlignRight, aTextAlignCenter: WORD;
- aTextAlignMask: Byte;
- aVertAlignCenter, aVertAlignTop, aVertAlignBottom: Byte;
- aDir, aSetLimit: Word; aSetImgList: Word;
- aAutoSzX, aAutoSzY: Word;
- aSetBkColor: Word;
- aItem2XY: Word;
- end;
- {$ENDIF WIN}
-
- //[Align TYPES]
- TTextAlign = ( taLeft, taRight, taCenter );
- {* Text alignments available. }
- TRichTextAlign = ( raLeft, raRight, raCenter,
- // all other are only set but can not be displayed:
- raJustify, // displayed like raLeft (though stored normally)
- raInterLetter, raScaled, raGlyphs, raSnapGrid );
- {* Text alignment styles, available for RichEdit control. }
- TVerticalAlign = ( vaCenter, vaTop, vaBottom );
- {* Vertical alignments available. }
- TControlAlign = ( caNone, caLeft, caTop, caRight, caBottom, caClient );
- {* Control alignments available. }
- TAligning = (oaWaitAlign,oaFromSelf,oaAligning);
- TAlignings = set of TAligning;
-
- //[BitBtn TYPES]
- TBitBtnOption = ( bboImageList,
- bboNoBorder,
- bboNoCaption,
- bboFixed,
- bboFocusRect );
- {* Options available for NewBitBtn. }
- TBitBtnOptions = set of TBitBtnOption;
- {* Set of options, available for NewBitBtn. }
- TGlyphLayout = ( glyphLeft, glyphTop, glyphRight, glyphBottom, glyphOver );
- {* Layout of glyph (for NewBitBtn). Layout glyphOver means that text is
- drawn over glyph. }
- TOnBitBtnDraw = function( Sender: PControl; BtnState: Integer ): Boolean of object;
- {* Event type for TControl.OnBitBtnDraw event (which is called just before
- drawing the BitBtn). If handler returns True, there are no drawing occure.
- BtnState, passed to a handler, determines current button state and can
- be following: 0 - not pressed, 1 - disabled, 2 - pressed, 3 - focused.
- Value 4 is reserved for highlight state (then mouse is over it), but
- highlighting is provided only if property Flat is set to True (or one
- of events OnMouseEnter / OnMouseLeave is assigned to something). }
-
- //[ListView TYPES]
- TListViewStyle = ( lvsIcon, lvsSmallIcon, lvsList, lvsDetail, lvsDetailNoHeader );
- {* Styles of view for ListView control (see NewListVew). }
-
- TListViewItemStates = ( lvisFocus, lvisSelect, lvisBlend, lvisHighlight );
- TListViewItemState = Set of TListViewItemStates;
- TListViewOption = (
- lvoIconLeft, // in lvsIcon, lvsSmallIcon place icon left from text (rather then top)
- lvoAutoArrange, // keep icons auto arranged in lvsIcon and lvsSmallIcon view
- lvoButton, // icons look like buttons in lvsIcon view
- lvoEditLabel, // allows edit labels inplace (first column #0 text)
- lvoNoLabelWrap, // item text on a single line in lvsIcon view (by default, item text may wrap in lvsIcon view).
- lvoNoScroll, // obvious
- lvoNoSortHeader, // click on header button does not lead to sort items
- lvoHideSel, // hide selection when not in focus
- lvoMultiselect, // allow to select multiple items
- lvoSortAscending,
- lvoSortDescending,
- // extended styles (not documented in my Win32.hlp :( , got from VCL source:
- lvoGridLines,
- lvoSubItemImages,
- lvoCheckBoxes,
- lvoTrackSelect,
- lvoHeaderDragDrop,
- lvoRowSelect,
- lvoOneClickActivate,
- lvoTwoClickActivate,
- lvoFlatsb,
- lvoRegional,
- lvoInfoTip,
- lvoUnderlineHot,
- lvoMultiWorkares,
- // virtual list view style:
- lvoOwnerData,
- // custom draw style:
- lvoOwnerDrawFixed
- );
- TListViewOptions = Set of TListViewOption;
-
- TOnEditLVItem = function( Sender: PControl; Idx, Col: Integer; NewText: PKOL_Char ): Boolean
- of object;
- {* Event type for OnEndEditLVItem. Return True in handler to accept new text value. }
- TOnDeleteLVItem = procedure( Sender: PControl; Idx: Integer ) of object;
- {* Event type for OnDeleteLVItem event. }
- TOnLVData = procedure( Sender: PControl; Idx, SubItem: Integer;
- var Txt: KOL_String; var ImgIdx: Integer; var State: DWORD;
- var Store: Boolean ) of object;
- {* Event type for OnLVData event. Used to provide virtual list view control
- (i.e. having lvoOwnerData style) with actual data on request. Use parameter
- Store as a flag if control should store obtained data by itself or not. }
- {$IFDEF ENABLE_DEPRECATED}
- {$DEFINE interface_1} {$I KOL_deprecated.inc} {$UNDEF interface_1}
- {$ENDIF DISABLE_DEPRECATED}
- TOnCompareLVItems = function( Sender: PControl; Idx1, Idx2: Integer ): Integer
- of object;
- {* Event type to compare two items of the list view (while sorting it). }
- TOnLVColumnClick = procedure( Sender: PControl; Idx: Integer ) of object;
- {* Event type for OnColumnClick event. }
- TOnLVStateChange = procedure( Sender: PControl; IdxFrom, IdxTo: Integer; OldState, NewState: DWORD )
- of object;
- {* Event type for OnLVStateChange event, called in responce to select/unselect
- a single item or items range in list view control). }
-
- TDrawActions = ( odaEntire, odaFocus, odaSelect );
- TDrawAction = Set of TDrawActions;
- TDrawStates = ( odsSelected, odsGrayed, odsDisabled, odsChecked, odsFocused,
- odsDefault, odsHotlist, odsInactive,
- odsNoAccel, odsNoFocusRect,
- ods400reserved, ods800reserved,
- odsComboboxEdit,
- // specific for common controls:
- odsMarked, odsIndeterminate );
- {* Possible draw states.
- |<br>odsSelected - The menu item's status is selected.
- |<br>odsGrayed - The item is to be grayed. This bit is used only in a menu.
- |<br>odsDisabled - The item is to be drawn as disabled.
- |<br>odsChecked - The menu item is to be checked. This bit is used only in
- a menu.
- |<br>odsFocused - The item has the keyboard focus.
- |<br>odsDefault - The item is the default item.
- |<br>odsHotList - <b>Windows 98, Windows 2000:</b> The item is being
- hot-tracked, that is, the item will be highlighted when
- the mouse is on the item.
- |<br>odsInactive - <b>Windows 98, Windows 2000:</b> The item is inactive
- and the window associated with the menu is inactive.
- |<br>odsNoAccel - <b>Windows 2000:</b> The control is drawn without the
- keyboard accelerator cues.
- |<br>odsNoFocusRect - <b>Windows 2000:</b> The control is drawn without
- focus indicator cues.
- |<br>odsComboboxEdit - The drawing takes place in the selection field
- (edit control) of an owner-drawn combo box.
- |<br>odsMarked - for Common controls only. The item is marked. The meaning
- of this is up to the implementation.
- |<br>odsIndeterminate - for Common Controls only. The item is in an
- indeterminate state. }
- TDrawState = Set of TDrawStates;
- {* Set of possible draw states. }
- TOnDrawItem = function( Sender: PObj; DC: HDC; const Rect: TRect; ItemIdx: Integer;
- DrawAction: TDrawAction; ItemState: TDrawState ): Boolean of object;
- {* Event type for OnDrawItem event (applied to list box, combo box, list view). }
- TOnMeasureItem = function( Sender: PObj; Idx: Integer ): Integer of object;
- {* Event type for OnMeasureItem event. The event handler must return height of list box
- item as a result. }
- TGetLVItemPart = ( lvipBounds, lvipIcon, lvipLabel, lvupIconAndLabel );
- {* }
- TWherePosLVItem = ( lvwpOnIcon, lvwpOnLabel, lvwpOnStateIcon, lvwpOnColumn,
- lvwpOnItem );
- {* }
-
- TOnLVCustomDraw = function( Sender: PControl; DC: HDC; Stage: DWORD;
- ItemIdx, SubItemIdx: Integer; const Rect: TRect;
- ItemState: TDrawState; var TextColor, BackColor: TColor )
- : DWORD of object;
- {* Event type for OnLVCustomDraw event. }
-
- //[Paint TYPES]
- TOnPaint = procedure( Sender: PControl; DC: HDC ) of object;
- TPaintProc = procedure( DC: HDC ) of object;
-
- TGradientStyle = ( gsVertical, gsHorizontal, gsRectangle, gsElliptic, gsRombic,
- gsTopToBottom, gsBottomToTop );
- {* Gradient fill styles. See also TGradientLayout. }
- TGradientLayout = ( glTopLeft, glTop, glTopRight,
- glLeft, glCenter, glRight,
- glBottomLeft, glBottom, glBottomRight );
- {* Position of starting line / point for gradient filling. Depending on
- TGradientStyle, means either position of first line of first rectangle
- (ellipse) to be expanded in a loop to fit entire gradient panel area. }
-
- //[Edit TYPES]
- TEditOption = ( eoNoHScroll, eoNoVScroll, eoLowercase, eoMultiline,
- eoNoHideSel, eoOemConvert, eoPassword, eoReadonly,
- eoUpperCase, eoWantReturn, eoWantTab, eoNumber );
- {* Available edit options.
- |<br> Please note, that eoWantTab option just removes TAB key from a list
- of keys available to tabulate from the edit control. To provide insertion
- of tabulating key, do so in TControl.OnChar event handler. Sorry for
- inconvenience, but this is because such behaviour is not must in all cases.
- See also TControl.EditTabChar property. }
- TEditOptions = Set of TEditOption;
- {* Set of available edit options. }
-
- TEditPositions = {$ifndef wince}packed{$endif} record
- SelStart: Integer;
- SelLength: Integer;
- TopLine: Integer;
- TopColumn: Integer;
- ScrollPos: TPoint;
- RestoreScroll: Boolean;
- end;
-
- TRichFmtArea = ( raSelection, raWord, raAll );
- {* Characters formatting area for RichEdit. }
- TRETextFormat = ( reRTF, reText, rePlainRTF, reRTFNoObjs, rePlainRTFNoObjs,
- reTextized, reUnicode, reTextUnicode );
- {* Available formats for transfer RichEdit text using property
- TControl.RE_Text.
- |<pre>
- reRTF - normal rich text (no transformations)
- reText - plain text only (without OLE objects)
- reTextized - plain text with text representation of COM objects
- rePlainRTF - reRTF without language-specific keywords
- reRTFNoObjs - reRTF without OLE objects
- rePlainRTFNoObjs - rePlainRTF without OLE objects
- reUnicode - stream is 2-byte Unicode characters rather then 1-byte Ansi
- |</pre> }
- TRichUnderline = ( ruSingle, ruWord, ruDouble, ruDotted,
- //all other - only for RichEditv3.0:
- ruDash, ruDashDot, ruDashDotDot, ruWave, ruThick, ruHairLine );
- {* Rich text exteded underline styles (available only for RichEdit v2.0,
- and even for RichEdit v2.0 additional styles can not displayed - but
- ruDotted under Windows2000 is working). }
- TRichTextSizes = ( rtsNoUseCRLF, rtsNoPrecise, rtsClose, rtsBytes );
- {* Options to calculate size of rich text. Available only for RichEdit2.0
- or higher. }
- TRichTextSize = set of TRichTextSizes;
- {* Set of all available optioins to calculate rich text size using
- property TControl.RE_TextSize[ options ]. }
- TRichNumbering = ( rnNone, rnBullets, rnArabic, rnLLetter, rnULetter,
- rnLRoman, rnURoman );
- {* Advanced numbering styles for paragraph (RichEdit).
- |<pre>
- rnNone - no numbering
- rnBullets - bullets only
- rnArabic - 1, 2, 3, 4, ...
- rnLLetter - a, b, c, d, ...
- rnULetter - A, B, C, D, ...
- rnLRoman - i, ii, iii, iv, ...
- rnURoman - I, II, III, IV, ...
- rnNoNumber - do not show any numbers (but numbering is taking place).
- |</pre> }
- TRichNumBrackets = ( rnbRight, rnbBoth, rnbPeriod, rnbPlain, rnbNoNumber );
- {* Brackets around number:
- |<pre>
- rnbRight - 1) 2) 3) - this is default !
- rnbBoth - (1) (2) (3)
- rnbPeriod - 1. 2. 3.
- rnbPlain - 1 2 3
- |</pre> }
- TBorderEdge = (beLeft, beTop, beRight, beBottom);
- {* Borders of rectangle. }
-
- {$IFNDEF NOT_USE_RICHEDIT}
- TCharFormat = TCharFormat2;
- TParaFormat = TParaFormat2;
- {$ENDIF NOT_USE_RICHEDIT}
-
- TOnTestMouseOver = function( Sender: PControl ): Boolean of object;
- {* Event type for TControl.OnTestMouseOver event. The handler should
- return True, if it dectects, that mouse is over control. }
-
- TEdgeStyle = ( esRaised, esLowered, esNone, esTransparent );
- {* Edge styles (for panel - see NewPanel). }
-
- //[List TYPES]
- TListOption = ( loNoHideScroll, loNoExtendSel, loMultiColumn, loMultiSelect,
- loNoIntegralHeight, loNoSel, loSort, loTabstops,
- loNoStrings, loNoData, loOwnerDrawFixed, loOwnerDrawVariable,
- loHScroll );
- {* Options for ListBox (see NewListbox).
- To use loHScroll, you also have to send LB_SETHORIZONTALEXTENT with a
- maximum width of a line in pixels (wParam)! }
- TListOptions = Set of TListOption;
- {* Set of available options for Listbox. }
-
- TComboOption = ( coReadOnly, coNoHScroll, coAlwaysVScroll, coLowerCase,
- coNoIntegralHeight, coOemConvert, coSort, coUpperCase,
- coOwnerDrawFixed, coOwnerDrawVariable, coSimple );
- {* Options for combobox. }
- TComboOptions = Set of TComboOption;
- {* Set of options available for combobox. }
-
- //[Progress TYPES]
- TProgressbarOption = ( pboVertical, pboSmooth );
- {* Options for progress bar. }
- TProgressbarOptions = set of TProgressbarOption;
- {* Set of options available for progress bar. }
-
- //[TreeView TYPES]
- TTreeViewOption = ( tvoNoLines, tvoLinesRoot, tvoNoButtons, tvoEditLabels, tvoHideSel,
- tvoDragDrop, tvoNoTooltips, tvoCheckBoxes, tvoTrackSelect,
- tvoSingleExpand, tvoInfoTip, tvoFullRowSelect, tvoNoScroll,
- tvoNonEvenHeight );
- {* Tree view options. }
- TTreeViewOptions = set of TTreeViewOption;
- {* Set of tree view options. }
-
- //[TabControl TYPES]
- TTabControlOption = ( tcoButtons, tcoFixedWidth, tcoFocusTabs,
- tcoIconLeft, tcoLabelLeft,
- tcoMultiline, tcoMultiselect, tcoFitRows, tcoScrollOpposite,
- tcoBottom, tcoVertical, tcoFlat, tcoHotTrack, tcoBorder,
- tcoOwnerDrawFixed );
- {* Options, available for TabControl. }
- TTabControlOptions = set of TTabControlOption;
- {* Set of options, available for TAbControl during its creation (by
- NewTabControl function). }
-
- //[Toolbar TYPES]
- TToolbarOption = ( tboTextRight, tboTextBottom, tboFlat, tboTransparent,
- tboWrapable, tboNoDivider, tbo3DBorder, tboCustomErase );
- {* Toolbar options. When tboFlat is set and toolbar is placed onto panel,
- set its property Transparent to TRUE to provide its correct view. }
- TToolbarOptions = Set of TToolbarOption;
- {* Set of toolbar options. }
- TOnToolbarButtonClick = procedure( Sender: PControl; BtnID: Integer ) of object;
- {* Special event type to handle separate toolbar buttons click events. }
- {$ifndef wince}
- TOnTBCustomDraw = function( Sender: PControl; var NMCD: TNMTBCustomDraw ): Integer of object;
- {* Event type for OnTBCustomDraw event. }
- {$endif wince}
-
- TDateTimePickerOption = ( dtpoTime, dtpoDateLong, dtpoUpDown, dtpoRightAlign,
- dtpoShowNone, dtpoParseInput );
- {* }
- TDateTimePickerOptions = set of TDateTimePickerOption;
- {* }
- TDTParseInputEvent = procedure(Sender: PControl; const UserString: string;
- var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
- {* }
- TDateTimeRange = {$ifndef wince}packed{$endif} record
- FromDate, ToDate: TDateTime;
- end;
- {* }
- TDateTimePickerColor = ( dtpcBackground, dtpcMonthBk, dtpcText, dtpcTitleBk,
- dtpcTitleText, dtpcTrailingText );
-
- //[TOnDropFiles TYPE]
- TOnDropFiles = procedure( Sender: PControl; const FileList: KOL_String; const Pt: TPoint ) of object;
- {* An event type for OnDropFiles event. When the event is occur, FileList
- parameter contains a list of files dropped. File names in a list are
- separated with #13 character. This allows You to assign it to TStrList
- object using its property Text (for example):
- ! procedure TSomeObject.DropFiles( Sender: PControl; const FileList: String;
- ! const Pt: TPoint ); )
- ! var FList: PStrList;
- ! I: Integer;
- ! begin
- ! FList := NewStrList;
- ! FList.Text := FileList;
- ! for I := 0 to FList.Count-1 do
- ! begin
- ! // do something with FList.Items[ I ]
- ! end;
- ! FList.Free;
- ! end; }
-
- //[Scroll TYPES]
- TScrollerBar = ( sbHorizontal, sbVertical );
- TScrollerBars = set of TScrollerBar;
-
- TOnScroll = procedure( Sender: PControl; Bar: TScrollerBar; ScrollCmd: DWORD;
- ThumbPos: DWORD ) of object;
-
- //[TOnHelp EVENT TYPE]
- TOnHelp = procedure( var Sender: PControl; var Context: Integer; var Popup: Boolean )
- of object;
-
- //[ScrollBar TYPES]
- TOnSBBeforeScroll =
- procedure(
- Sender: PControl; OldPos, NewPos: Integer; Cmd: Word;
- var AllowChange: Boolean) of object;
- TOnSBScroll = procedure(Sender: PControl; Cmd: Word) of object;
-
- {$IFDEF WIN_GDI}
- TOnGraphCtlMouse = procedure( var Msg: TMsg ) of object;
- {$ENDIF WIN_GDI}
- TTriStateCheck = (tsUnchecked{=0}, tsChecked{=1}, tsIndeterminate{=2});
-
- {$IFDEF _X_}
- //---- in GTK+, each type of widget requieres its own getcaption/setcaption call
- TGetCaption = function( Ctl: PControl ): KOLString;
- TSetCaption = procedure( Ctl: PControl; const Value: KOLString );
-
- {$IFDEF GTK}
- //---- in GTK+, to allow setting absolute position for children,
- // we should use one of special clients like gtk_fixed, gtk_layout
- TGetClientArea = function( Ctl: PControl ): PGtkWidget;
- TChildSetPos = procedure( Ctl, Chld: PControl; x, y: Integer );
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE pre_interface}
- {$I KOLMHToolTip.pas}
- {$UNDEF pre_interface}
- {$ENDIF}
-
- { ----------------------------------------------------------------------
- TControl - object to implement any visual control
- ----------------------------------------------------------------------- }
- //[TControl DEFINITION]
- TControl = object( TObj )
- {* Object to implement any visual control }
- {$IFDEF GDI}
- protected
- fSBMinMax: TPoint;
- fSBPageSize: Integer;
- fSBPosition: Integer;
- procedure SetSBMax(Value: Longint);
- procedure SetSBMin(Value: Longint);
- procedure SetSBPageSize(Value: Integer);
- procedure SetSBPosition(Value: Integer);
- procedure SetSBMinMax(const Value: TPoint);
-
- function GetDate: TDateTime;
- function GetTime: TDateTime;
- procedure SetDate(const Value: TDateTime);
- procedure SetTime(const Value: TDateTime);
- {*! TControl is the basic visual object of KOL. And now, all visual
- objects have the same type PControl, differing only in "constructor",
- which during creating of object adjusts it so it can play role of
- desired control. Idea of incapsulating of all visual objects having
- the most common set of properties, is belonging to Vladimir Kladov,
- (C) 2000.
- |<br> <b> Since all visual objects are represented
- in KOL by this single object type, not all methods, properties and
- events defined in TControl, are applicable to different visual objects.
- See also notes about certain control kinds, located together with its
- |<a href="kol_pas.htm#visual_objects_constructors">
- |constructing functions definitions</a></b>. }
- {$ENDIF GDI}
- protected
- {$IFDEF GDI}
- function GetHelpPath: KOLString;
- procedure SetHelpPath(const Value: KOLString);
- procedure SetOnQueryEndSession(const Value: TOnEventAccept);
- procedure SetOnMinMaxRestore(const Index: Integer; const Value: TOnEvent);
- procedure SetOnMinimize( const Value: TOnEvent );
- procedure SetOnMaximize( const Value: TOnEvent );
- procedure SetOnRestore( const Value: TOnEvent );
- procedure SetConstraint(const Index, Value: Integer);
- {$IFDEF F_P}
- function GetOnMinMaxRestore(const Index: Integer): TOnEvent;
- function GetConstraint(const Index: Integer): Integer;
- {$ENDIF F_P}
- procedure SetOnScroll(const Value: TOnScroll);
- function GetLVColalign(Idx: Integer): TTextAlign;
- procedure SetLVColalign(Idx: Integer; const Value: TTextAlign);
-
- {$ENDIF GDI}
- procedure SetParent( Value: PControl );
- function GetLeft: Integer;
- procedure SetLeft( Value: Integer );
- function GetTop: Integer;
- procedure SetTop( Value: Integer );
- function GetWidth: Integer;
- procedure SetWidth( Value: Integer );
- function GetHeight: Integer;
- procedure SetHeight( Value: Integer );
- function GetPosition: TPoint;
- procedure Set_Position( Value: TPoint );
- function GetMembers(Idx: Integer): PControl;
- function GetFont: PGraphicTool;
- procedure FontChanged( Sender: PGraphicTool );
- {$IFDEF GDI}
- function GetBrush: PGraphicTool;
- procedure BrushChanged( Sender: PGraphicTool );
- function GetClientHeight: Integer;
- function GetClientWidth: Integer;
- procedure SetClientHeight(const Value: Integer);
- procedure SetClientWidth(const Value: Integer);
- function GetHasBorder: Boolean;
- procedure SetHasBorder(const Value: Boolean);
-
- function GetHasCaption: Boolean;
- procedure SetHasCaption(const Value: Boolean);
-
- function GetCanResize: Boolean;
- procedure SetCanResize( const Value: Boolean );
-
- function GetStayOnTop: Boolean;
- procedure SetStayOnTop(const Value: Boolean);
- function GetChecked: Boolean;
- procedure Set_Checked(const Value: Boolean);
-
- function GetCheck3: TTriStateCheck;
- procedure SetCheck3(value: TTriStateCheck);
-
- function GetSelStart: Integer;
- procedure SetSelStart(const Value: Integer);
- function GetSelLength: Integer;
- procedure SetSelLength(const Value: Integer);
-
- function GetItems(Idx: Integer): KOLString;
- procedure SetItems(Idx: Integer; const Value: KOLString);
-
- function GetItemsCount: Integer;
- function GetItemSelected(ItemIdx: Integer): Boolean;
- procedure SetItemSelected(ItemIdx: Integer; const Value: Boolean);
-
- procedure SetCtl3D(const Value: Boolean);
- function GetCurIndex: Integer;
- procedure SetCurIndex(const Value: Integer);
-
- {$ENDIF GDI}
- function GetTextAlign: TTextAlign;
- procedure SetTextAlign(const Value: TTextAlign);
- function GetVerticalAlign: TVerticalAlign;
- procedure SetVerticalAlign(const Value: TVerticalAlign);
- function GetCanvas: PCanvas;
- {$IFDEF _X_}
- {$IFDEF GTK}
- protected
- fInBkPaint: Boolean;
- fSetTextAlign: procedure( Self_: PControl );
- function ProvideCanvasHandle( Sender: PCanvas ): HDC;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- function Dc2Canvas( Sender: PCanvas ): HDC;
- procedure SetShadowDeep(const Value: Integer);
- procedure SetDoubleBuffered(const Value: Boolean);
-
- procedure SetStatusText(Index: Integer; Value: PKOLChar);
- function GetStatusText( Index: Integer ): PKOLChar;
- function GetStatusPanelX(Idx: Integer): Integer;
- procedure SetStatusPanelX(Idx: Integer; const Value: Integer);
-
- procedure SetTransparent(const Value: Boolean);
- function GetImgListIdx(const Index: Integer): PImageList;
-
- procedure SetImgListIdx(const Index: Integer; const Value: PImageList);
- function GetLVColText(Idx: Integer): KOLString;
- procedure SetLVColText(Idx: Integer; const Value: KOLString);
- {$IFDEF ENABLE_DEPRECATED}
- {$DEFINE interface_2} {$I KOL_deprecated.inc} {$UNDEF interface_2}
- {$ENDIF DISABLE_DEPRECATED}
- protected
- function LVGetItemText(Idx, Col: Integer): KOLString;
- procedure LVSetItemText(Idx, Col: Integer; const Value: KOLString);
- procedure SetLVOptions(const Value: TListViewOptions);
- procedure SetLVStyle(const Value: TListViewStyle);
- function GetLVColEx(Idx: Integer; const Index: Integer): Integer;
- procedure SetLVColEx(Idx: Integer; const Index: Integer;
- const Value: Integer);
- {$ENDIF GDI}
- function GetChildCount: Integer;
- {$IFDEF GDI}
- function LVGetItemPos(Idx: Integer): TPoint;
- procedure LVSetItemPos(Idx: Integer; const Value: TPoint);
- procedure LVSetColorByIdx(const Index: Integer; const Value: TColor);
- {$IFDEF F_P}
- function LVGetColorByIdx(const Index: Integer): TColor;
- {$ENDIF F_P}
- function GetIntVal(const Index: Integer): Integer;
- procedure SetIntVal(const Index, Value: Integer);
- function GetItemVal(Item: Integer; const Index: Integer): Integer;
- procedure SetItemVal(Item: Integer; const Index, Value: Integer);
- function TBGetButtonVisible(BtnID: Integer): Boolean;
- procedure TBSetButtonVisible(BtnID: Integer; const Value: Boolean);
-
- function TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
- procedure TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
- function TBGetButtonText(BtnID: Integer): KOLString;
- function TBGetButtonRect(BtnID: Integer): TRect;
-
- function TBGetRows: Integer;
- procedure TBSetRows(const Value: Integer);
- procedure SetProgressColor(const Value: TColor);
- function TBGetBtnImgIdx(BtnID: Integer): Integer;
- procedure TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
-
- procedure TBSetButtonText(BtnID: Integer; const Value: KOLString);
-
- function TBGetBtnWidth(BtnID: Integer): Integer;
- procedure TBSetBtnWidth(BtnID: Integer; const Value: Integer);
- procedure TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
- {$IFDEF F_P}
- function TBGetBtMinMaxWidth(const Idx: Integer): Integer;
- {$ENDIF F_P}
- procedure TBFreeTBevents;
- procedure Set_Align(const Value: TControlAlign);
- function GetSelection: KOLString;
- procedure SetSelection(const Value: KOLString);
- procedure SetTabOrder(const Value: Integer);
- function GetFocused: Boolean;
- procedure SetFocused(const Value: Boolean);
- {$IFNDEF NOT_USE_RICHEDIT}
- function REGetFont: PGraphicTool;
- procedure RESetFont(Value: PGraphicTool);
- procedure RESetFontEx(const Index: Integer);
- function REGetFontEffects(const Index: Integer): Boolean;
- function REGetFontMask(const Index: Integer): Boolean;
- procedure RESetFontEffect(const Index: Integer; const Value: Boolean);
- function REGetFontAttr(const Index: Integer): Integer;
- procedure RESetFontAttr(const Index, Value: Integer);
- procedure RESetFontAttr1(const Index, Value: Integer);
- function REGetFontSizeValid: Boolean;
- function REGetCharformat: TCharFormat;
- procedure RESetCharFormat(const Value: TCharFormat);
- function REReadText(Format: TRETextFormat;
- SelectionOnly: Boolean): KOLString;
- procedure REWriteText(Format: TRETextFormat; SelectionOnly: Boolean;
- const Value: KOLString);
- function REGetFontName: KOLString;
- procedure RESetFontName(const Value: KOLString);
- function REGetParaFmt: TParaFormat;
- procedure RESetParaFmt(const Value: TParaFormat);
- function REGetNumbering: Boolean;
- function REGetParaAttr( const Index: Integer ): Integer;
- function REGetParaAttrValid( const Index: Integer ): Boolean;
- function REGetTabCount: Integer;
- function REGetTabs(Idx: Integer): Integer;
- function REGetTextAlign: TRichTextAlign;
- procedure RESetNumbering(const Value: Boolean);
- procedure RESetParaAttr(const Index, Value: Integer);
- procedure RESetTabCount(const Value: Integer);
- procedure RESetTabs(Idx: Integer; const Value: Integer);
- procedure RESetTextAlign(const Value: TRichTextAlign);
- function REGetStartIndentValid: Boolean;
- function REGetAutoURLDetect: Boolean;
- procedure RESetAutoURLDetect(const Value: Boolean);
- procedure RESetZoom( const Value: TSmallPoint );
- function REGetZoom: TSmallPoint;
- {$ENDIF NOT_USE_RICHEDIT}
- function GetMaxTextSize: DWORD;
- procedure SetMaxTextSize(const Value: DWORD);
- function GetTextSize: Integer;
-
- procedure SetOnResize(const Value: TOnEvent);
-
- procedure DoSelChange;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- function REGetUnderlineEx: TRichUnderline;
- procedure RESetUnderlineEx(const Value: TRichUnderline);
-
- function REGetTextSize(Units: TRichTextSize): Integer;
-
- function REGetNumStyle: TRichNumbering;
- procedure RESetNumStyle(const Value: TRichNumbering);
- function REGetNumBrackets: TRichNumBrackets;
- procedure RESetNumBrackets(const Value: TRichNumBrackets);
- function REGetNumTab: Integer;
- procedure RESetNumTab(const Value: Integer);
- function REGetNumStart: Integer;
- procedure RESetNumStart(const Value: Integer);
- function REGetSpacing(const Index: Integer): Integer;
- procedure RESetSpacing(const Index, Value: Integer);
- function REGetSpacingRule: Integer;
- procedure RESetSpacingRule(const Value: Integer);
- function REGetLevel: Integer;
- function REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
- procedure RESetBorder(Side: TBorderEdge; const Index: Integer;
- const Value: Integer);
- function REGetParaEffect(const Index: Integer): Boolean;
- procedure RESetParaEffect(const Index: Integer; const Value: Boolean);
- function REGetOverwite: Boolean;
- procedure RESetOverwrite(const Value: Boolean);
- procedure RESetOvrDisable(const Value: Boolean);
- function REGetTransparent: Boolean;
- procedure RESetTransparent(const Value: Boolean);
- procedure RESetOnURL(const Index: Integer; const Value: TOnEvent);
- procedure SetOnRE_URLClick( const Value: TOnEvent );
- procedure SetOnRE_OverURL( const Value: TOnEvent );
- {$IFDEF F_P}
- function REGetOnURL(const Index: Integer): TOnEvent;
- {$ENDIF F_P}
- function REGetLangOptions(const Index: Integer): Boolean;
- procedure RESetLangOptions(const Index: Integer; const Value: Boolean);
- {$ENDIF NOT_USE_RICHEDIT}
- function LVGetItemImgIdx(Idx: Integer): Integer;
- procedure LVSetItemImgIdx(Idx: Integer; const Value: Integer);
- procedure SetFlat(const Value: Boolean);
- procedure SetOnMouseEnter(const Value: TOnEvent);
- procedure SetOnMouseLeave(const Value: TOnEvent);
- procedure EdSetTransparent(const Value: Boolean);
- procedure SetOnTestMouseOver(const Value: TOnTestMouseOver);
- function GetPages(Idx: Integer): PControl;
- function TCGetItemText(Idx: Integer): KOLString;
- procedure TCSetItemText(Idx: Integer; const Value: KOLString);
- function TCGetItemImgIDx(Idx: Integer): Integer;
- procedure TCSetItemImgIdx(Idx: Integer; const Value: Integer);
- function TCGetItemRect(Idx: Integer): TRect;
- function TVGetItemIdx(const Index: Integer): THandle;
- procedure TVSetItemIdx(const Index: Integer; const Value: THandle);
- function TVGetItemNext(Item: THandle; const Index: Integer): THandle;
- function TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
- function TVGetItemVisible(Item: THandle): Boolean;
- procedure TVSetITemVisible(Item: THandle; const Value: Boolean);
- function TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
- procedure TVSetItemStateFlg(Item: THandle; const Index: Integer;
- const Value: Boolean);
- function TVGetItemImage(Item: THandle; const Index: Integer): Integer;
- procedure TVSetItemImage(Item: THandle; const Index: Integer;
- const Value: Integer);
- function TVGetItemText(Item: THandle): KOLString;
- procedure TVSetItemText(Item: THandle; const Value: KOLString);
- function TV_GetItemHasChildren(Item: THandle): Boolean;
- procedure TV_SetItemHasChildren(Item: THandle; const Value: Boolean);
- function TV_GetItemChildCount(Item: THandle): Integer;
- function TVGetItemData(Item: THandle): Pointer;
- procedure TVSetItemData(Item: THandle; const Value: Pointer);
-
- function GetToBeVisible: Boolean;
-
- procedure SetAlphaBlend(const Value: Integer);
- procedure SetMaxProgress(const Index, Value: Integer);
- procedure SetDroppedWidth(const Value: Integer);
- function LVGetItemState(Idx: Integer): TListViewItemState;
- procedure LVSetItemState(Idx: Integer; const Value: TListViewItemState);
- function LVGetSttImgIdx(Idx: Integer): Integer;
- procedure LVSetSttImgIdx(Idx: Integer; const Value: Integer);
- function LVGetOvlImgIdx(Idx: Integer): Integer;
- procedure LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
- function LVGetItemData(Idx: Integer): DWORD;
- procedure LVSetItemData(Idx: Integer; const Value: DWORD);
- function LVGetItemIndent(Idx: Integer): Integer;
- procedure LVSetItemIndent(Idx: Integer; const Value: Integer);
- procedure SetOnDeleteAllLVItems(const Value: TOnEvent);
- procedure SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
- procedure SetOnEndEditLVItem(const Value: TOnEditLVItem);
- procedure SetOnLVData(const Value: TOnLVData);
- procedure SetOnColumnClick(const Value: TOnLVColumnClick);
- procedure SetOnDrawItem(const Value: TOnDrawItem);
- procedure SetOnMeasureItem(const Value: TOnMeasureItem);
-
- procedure SetItemsCount(const Value: Integer);
-
- function GetItemData(Idx: Integer): DWORD;
- procedure SetItemData(Idx: Integer; const Value: DWORD);
- function GetLVCurItem: Integer;
- procedure SetLVCurItem(const Value: Integer);
- function GetLVFocusItem: Integer;
- procedure SetOnDropFiles(const Value: TOnDropFiles);
- procedure SetOnHide(const Value: TOnEvent);
- procedure SetOnShow(const Value: TOnEvent);
- procedure SetClientMargin(const Index, Value: Integer);
- {$IFDEF F_P}
- function GetClientMargin(const Index: Integer): Integer;
- {$ENDIF F_P}
- {$ENDIF GDI}
- protected
- {$IFDEF _X_}
- {$IFDEF GTK}
- fExposeEvent: Integer;
- {$ENDIF GTK}
- {$ENDIF _X_}
- procedure SetOnPaint(const Value: TOnPaint);
- {$IFDEF GDI}
- procedure SetOnEraseBkgnd(const Value: TOnPaint);
- procedure SetTVRightClickSelect(const Value: Boolean);
- procedure SetOnLVStateChange(const Value: TOnLVStateChange);
- procedure SetOnMove(const Value: TOnEvent);
- procedure SetOnMoving(const Value: TOnEventMoving);
- procedure SetColor1(const Value: TColor);
- procedure SetColor2(const Value: TColor);
- procedure SetGradientLayout(const Value: TGradientLayout);
- procedure SetGradientStyle(const Value: TGradientStyle);
- procedure SetDroppedDown(const Value: Boolean);
- function get_ClassName: KOLString;
- procedure set_ClassName(const Value: KOLString);
- procedure SetClsStyle( Value: DWord );
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- procedure SetEdgeStyle( Value: TEdgeStyle );
- {$ENDIF}
-
- procedure SetStyle( Value: DWord );
- procedure SetExStyle( Value: DWord );
-
- procedure SetCursor( Value: HCursor );
-
- procedure SetIcon( Value: HIcon );
- procedure SetMenu( Value: HMenu );
- {$ENDIF GDI}
- protected
- {$IFDEF _X_}
- fGetCaption: TGetCaption;
- fSetCaption: TSetCaption;
- {$ENDIF _X_}
- function GetCaption: KOLString;
- procedure SetCaption( const Value: KOLString );
- {$IFDEF GDI}
-
- procedure SetWindowState( Value: TWindowState );
- function GetWindowState: TWindowState;
-
- {$ENDIF GDI}
- procedure ApplyFont2Wnd;
- {$IFDEF GDI}
- procedure DoClick;
-
- function TBAddInsButtons( Idx: Integer; const Buttons: array of PKOLChar;
- const BtnImgIdxArray: array of Integer ): Integer;
- procedure SetBitBtnDrawMnemonic(const Value: Boolean);
- function GetBitBtnImgIdx: Integer;
- procedure SetBitBtnImgIdx(const Value: Integer);
- function GetBitBtnImageList: THandle;
- procedure SetBitBtnImageList(const Value: THandle);
-
- function GetModal: Boolean;
- {$IFDEF USE_SETMODALRESULT}
- procedure SetModalResult( const Value: Integer );
- {$ENDIF}
-
- {$ENDIF GDI}
- protected
- {$IFDEF GDI}
- fHandle: HWnd;
- {$ELSE}
- {$IFDEF GTK} fHandle: PGtkWidget;
- fCaptionHandle: PGtkWidget;
- fEventboxHandle: PGtkWidget;
- fGetClientArea: TGetClientArea;
- fClient: PGtkWidget;
- fChildPut: TChildSetPos;
- fChildSetPos: TChildSetPos;
- {$ENDIF}
- {$IFDEF Q_T} fHandle: sometypehere ; {$ENDIF}
- {$ENDIF}
- {$IFDEF GDI}
- fFocusHandle: HWnd;
- fClsStyle: DWord;
- fStyle: DWord;
- fExStyle: DWord;
- fCursor: HCursor;
- fCursorShared: Boolean;
- fIcon: HIcon;
- fIconShared: Boolean;
- {$ENDIF GDI}
- fIgnoreWndCaption: Boolean;
- {$IFDEF GDI}
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- fEdgeStyle : TEdgeStyle;
- {$ENDIF}
-
- fWindowState: TWindowState;
- //fShowAction: Integer;
- fDefWndProc: Pointer;
- fNCDestroyed: Boolean;
-
- {$ENDIF GDI}
- FParent: PControl;
- fEnabled: Boolean; // Caution!!! fVisible must follow fEnabled! ___
- fVisible: Boolean; //____________________________________________//
- fTabstop: Boolean;
- fTabOrder: Integer;
- fTextAlign: TTextAlign;
- fVerticalAlign: TVerticalAlign;
- fWordWrap: Boolean;
- fPreventResize: Boolean;
- {$IFDEF GDI}
- fAlphaBlend: Integer;
- {$ENDIF GDI}
- FDroppedWidth: Integer;
-
- // Caution!!! order of following 5 fields is important!!!
- fDynHandlers: PList;
- fChildren: PList;
- {* List of children. }
- {$ifndef wince}
- fTBttCmd: PList;
- {$endif wince}
- fTBttTxt: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
- {$IFDEF GDI}
- fTmpFont: PGraphicTool;
- {$ENDIF GDI}
- //________________________________________________________//
- {$IFDEF GDI}
-
- fMDIClient: PControl;
- {* MDI client window control }
- fMDIChildren: PList;
- {* List of MDI children. It is filled for MDI client window. }
- fWndFunc: Pointer;
- {* Initially pointer to WndFunc. For MDI child window, points to DefMDIChildProc. }
- fExMsgProc: function( Applet: PControl; var Msg: TMsg ): Boolean;
- {* Additional message handler called directly from Applet.ProcessMessage.
- Used to call TranslateMDISysAccel API function for MDI application. }
- fMDIDestroying: Boolean;
- {* }
-
- fTmpBrush: HBrush;
- {* Brush handle to return in response to some color set messages.
- Intended for internal use instead of Brush.Color if possible
- to avoid using it. }
- fTmpBrushColorRGB: TColor;
- { }
- fMembersCount: Integer;
- {* Memebers count is first used in XCustomControl to separate
- some internal child controls from common XControl.Children
- and make it invisible among Children[]. }
- fDrawCtrl1st: PControl;
- {* Child control to draw it first, i.e. foreground of others. }
- FCreating: Boolean;
- {* True, when creating of object is in progress. }
- fDestroying: Boolean;
- {* True, when destroying of the window is started. }
- fBeginDestroying: Boolean;
- {* true, when destroying of the window is initiated by the system, i.e.
- message WM_DESTROY fired }
- fNestedMsgHandling: Integer;
- {* level of nested message handling for a control. Only when it is 0 at
- the end of message handling and fBeginDestroying set, the control is
- destroyed. }
- fMenu: HMenu;
- {* Usually used to store handle of attached main menu, but sometimes
- is used to store control ID (for standard GUI controls only). }
- {$ENDIF GDI}
- fMenuObj: PObj;
- {* PMenu pointer to TMenu object. Freed automatically with entire
- chain of menu objects attached to a control (or form). }
- {$IFDEF _X_}
- {$IFDEF GTK}
- //fMenuBar: PGtkWidget;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- {$IFNDEF NEW_MENU_ACCELL}
- fAccelTable: HAccel;
- procedure DoDestroyAccelTable;
- {$ENDIF}
- {$ENDIF GDI}
- protected
- {$IFDEF GDI}
- {* Handle of accelerator table created by menu(s). }
- fImageList: PImageList;
- {* Pointer to first private image list. Control can own several image,
- lists, linked to a chain of image list objects. All these image lists
- are released automatically, when control is destroyed. }
- fCtlImageListSml: PImageList;
- {* ImageList object (with small icons 16x16) to use with a control (e.g.,
- with ListView control).
- If not set, but control has a list of image list objects, last added
- image list with small icons is used automatically. }
- fCtlImageListNormal: PImageList;
- {* ImageList object (with big icons 32x32) to use with a control.
- If not set, last added image list with big icons is used. }
- fCtlImgListState: PImageList;
- {* ImageList object to use as a state image list (for ListView control). }
- {$ENDIF GDI}
- fIsApplet: Boolean;
- {* True, if the object represent application taskbar button. }
- fIsForm: Boolean;
- {* True, if the object is form. }
- fIsButton: Boolean;
- {$IFDEF GDI}
- fSizeGrip: Boolean;
- {$ENDIF GDI}
- fIsMDIChild: Boolean;
- {* TRUE, if the object is MDI child form. }
- fIsControl: Boolean;
- {* True, if it is a control on form. }
- fIsStaticControl: Byte;
- {* True, if it is static control with a caption. (To prevent flickering
- it in DoubleBuffered mode. }
- {$IFDEF GDI}
- fIsCommonControl: Boolean;
- {* True, if it is common control. }
- {$ENDIF GDI}
- fChangedPosSz: Byte;
- {* Flags of changing left (1), top (2), width (4) or height (8) }
- {$IFDEF GDI}
- fCannotDoubleBuf: Boolean;
- {* True, if cannot set DoubleBuffered to True (RichEdit). }
- fUpdRgn: HRgn;
- fCollectUpdRgn: HRGN;
- fEraseUpdRgn: Boolean;
- fPaintDC: HDC;
- {$ENDIF GDI}
- fLookTabKeys: TTabKeys;
- {$IFDEF GDI}
- fNotUpdate: Boolean;
- fColumn: Integer;
- FSupressTab: Boolean;
- fUpdateCount: Integer;
- fPaintLater: Boolean;
- fOnLeave: TOnEvent;
- fEditing: Boolean;
- fAutoPopupMenu: PObj;
- fHelpContext: Integer;
- {$IFDEF USE_GRAPHCTLS}
- fDoInvalidate: procedure of object;
- {$ENDIF}
-
- {$IFDEF GTK}
- fDeltaX, fDeltaY: Integer;
- {$ENDIF GTK}
- // Order of following fields is important:
- //_______________________________________________________________________________________________
- fPass2DefProc: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- fOnDynHandlers: TWindowFunc; //
- fWndProcKeybd: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; //
- fControlClick: procedure( Sender : PObj ); //
- {$ENDIF GDI}
- fAutoSize: procedure( Self_: PObj );
- fControlClassName: PKOLChar; //
- {$IFDEF GDI}
- fWindowed: Boolean; //
- {* True, if control is windowed (or is a form). It is set to FALSE only for
- graphic controls. }
- // //
- fCtlClsNameChg: Boolean; //
- {* True, if control class name changed and memory is allocated to store it. } //
- fWndProcResizeFlicks: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; //
- {$ENDIF GDI}
- fGotoControl: function( Self_: PControl; Key: DWORD; CheckOnly: Boolean ): Boolean; //
- {$IFDEF GDI}
- fCtl3Dchild: Boolean; //
- fCtl3D: Boolean; //
- {$ENDIF GDI}
- fTextColor: TColor; //
- fColor: TColor; //
- {* Color of text. Used instead of fFont.Color internally to //
- avoid usage of Font object if user is not accessing and changing it. } //
- fFont: PGraphicTool; //
- fBrush: PGraphicTool; //
- fCanvas: PCanvas;
- {* Color of control background. } //
- fMargin: Integer; //
- fBoundsRect: TRect; //
- fClientTop, fClientBottom, fClientLeft, fClientRight: Integer; //
- {* Store adjustment factor of ClientRect for some 'idiosincrasies' windows, //
- such as Groupbox or Tabcontrol. } //
- //_____________________________________________________________________________________________//
- // this is the end of fiels set, which order is important
- {$IFDEF GDI}
-
- fDoubleBuffered: Boolean;
- fTransparent: Boolean;
- {$IFDEF GRAPHCTL_XPSTYLES}
- fClassicTransparent : boolean;
- {$ENDIF}
- fRETransparent: Boolean;
- fParentRequirePaint: boolean;
- fSelfRequirePaint: boolean;
- fDblExcludeRgn: HDC;
-
- fOnMessage: TOnMessage;
- fOldOnMessage: TOnMessage;
-
- {$ENDIF GDI}
- fOnClick: TOnEvent;
- fClickedEvent: Integer;
- {$IFDEF _X_}
- procedure SetOnClick( const Value: TOnEvent );
- {$ENDIF _X_}
- protected
- {$IFDEF GDI}
- fRightClick: Boolean;
- fCurrentControl: PControl;
- fCreateVisible, fCreateHidden: Boolean;
- fRadio1st, fRadioLast : THandle;
- fDropDownProc: procedure( Sender : PObj );
- fDropped: Boolean;
- fCurIdxAtDrop: Integer;
- fPrevWndProc: Pointer;
- fClickDisabled: Byte;
- fCurItem, fCurIndex: Integer;
- FOnScroll: TOnScroll;
- FScrollLineDist: array[ 0..1 ] of Integer;
-
- fDefaultBtn: Boolean;
- fCancelBtn: Boolean;
- fDefaultBtnCtl: PControl;
- fCancelBtnCtl: PControl;
- fAllBtnReturnClick: Boolean;
- fIgnoreDefault: Boolean;
-
- {$ENDIF GDI}
- fOnMouseDown: TOnMouse; // CAUTION!!! Order of mouse event handlers is important. ____
- fOnMouseUp: TOnMouse; //
- fOnMouseMove: TOnMouse; //
- fOnMouseDblClk: TOnMouse; //
- fOnMouseWheel: TOnMouse; //_____________________________________________________//
- f3ButtonPress: Boolean;
- {$IFDEF GDI}
-
- fOldDefWndProc: Pointer;
-
- fOnChange: TOnEvent;
- fOnEnter: TOnEvent;
-
- FOnLVCustomDraw: TOnLVCustomDraw;
- FOnSBBeforeScroll: TOnSBBeforeScroll;
- FOnSBScroll: TOnSBScroll;
- protected
- procedure SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
- public
- fCommandActions: TCommandActions;
- {$ENDIF GDI}
- protected
- {$IFDEF GDI}
- fOnChar: TOnChar;
- {$IFDEF SUPPORT_ONDEADCHAR}
- fOnDeadChar: TOnChar;
- {$ENDIF SUPPORT_ONDEADCHAR}
- fOnKeyUp: TOnKey;
- fOnKeyDown: TOnKey;
-
- {$ENDIF GDI}
- fOnPaint: TOnPaint;
- {$IFDEF GDI}
- fOnPaint2: TOnPaint;
- fPaintMsg: TMsg;
- fOnPrepaint: TOnPaint;
- fOnPostPaint: TOnPaint;
- fPaintProc: TPaintProc;
-
- {$ENDIF GDI}
- FMaxWidth: Integer;
- FMinWidth: Integer;
- FMaxHeight: Integer;
- FMinHeight: Integer;
- {$IFDEF GDI}
- fShadowDeep: Integer;
- fStatusCtl: PControl;
- fStatusWnd: HWnd;
- fColor1: TColor;
- fColor2: TColor;
- fLVColCount: Integer;
- fLVOptions: TListViewOptions;
- fLVStyle: TListViewStyle;
- fOnEndEditLVITem: TOnEditLVItem;
- fLVTextBkColor: TColor;
- fLVItemHeight: Integer;
-
- fOnDropDown: TOnEvent;
- fOnCloseUp: TOnEvent;
-
- fModalResult: Integer;
-
- fModal: Integer;
- fModalForm: PControl;
-
- {$ENDIF GDI}
- fAlign: TControlAlign;
- fAligning:TAlignings;
- fNotUseAlign: Boolean;
- {$IFDEF GDI}
- fDragCallback: TOnDrag;
- fDragging, fInDoDrag: Boolean;
- fDragStartPos: TPoint;
- fMouseStartPos: TPoint;
- fSplitStartPos: TPoint;
- fSplitStartPos2: TPoint;
- fSplitStartSize: Integer;
- fSplitMinSize1, fSplitMinSize2: Integer;
- fOnSplit: TOnSplit;
- fSecondControl: PControl;
- fOnSelChange: TOnEvent;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- fRECharFormatRec: TCharFormat2;
- fREError: Integer;
- fREStream: PStream;
- fREStrLoadLen: DWORD;
- fREParaFmtRec: TParaFormat2;
- {$ENDIF NOT_USE_RICHEDIT}
- FOnResize: TOnEvent;
- fOnProgress: TOnEvent;
- fCharFmtDeltaSz: Integer;
- fParaFmtDeltaSz: Integer;
- fREOvr: Boolean;
- fReOvrDisable: Boolean;
- fOnREInsModeChg: TOnEvent;
- fREScrolling: Boolean;
- fUpdCount: Integer;
- fOnREOverURL: TOnEvent;
- fOnREURLClick: TOnEvent;
- fRECharArea: TRichFmtArea;
- fBitBtnOptions : TBitBtnOptions;
- fGlyphLayout : TGlyphLayout;
- fGlyphBitmap : HBitmap;
- fGlyphCount : Integer;
- fGlyphWidth, fGlyphHeight: Integer;
- fOnBitBtnDraw: TOnBitBtnDraw;
- fFlat: Boolean;
- fSizeRedraw: Boolean; {YS}
-
- fOnMouseLeave: TOnEvent;
- fOnMouseEnter: TOnEvent;
- fOnTestMouseOver: TOnTestMouseOver;
-
- fMouseInControl: Boolean;
- fRepeatInterval: Integer;
- fChecked: Boolean;
- fPushed: Boolean;
- fPrevFocusWnd: HWnd;
-
- fOnTVBeginDrag: TOnTVBeginDrag;
- fOnTVBeginEdit: TOnTVBeginEdit;
- fOnTVEndEdit: TOnTVEndEdit;
- fOnTVExpanded: TOnTVExpanded;
- fOnTVExpanding: TOnTVExpanding;
- fOnTVDelete: TOnTVDelete;
-
- fOnDeleteLVItem: TOnDeleteLVItem;
- fOnDeleteAllLVItems: TOnEvent;
- fOnLVData: TOnLVData;
- fOnCompareLVItems: TOnCompareLVItems;
- fOnColumnClick: TOnLVColumnClick;
- fOnDrawItem: TOnDrawItem;
- fOnMeasureItem: TOnMeasureItem;
- fREUrl: KOLString;
- FMinimizeWnd: PControl;
- FFixWidth: Integer;
- FFixHeight: Integer;
- FOnDropFiles: TOnDropFiles;
- FOnHide: TOnEvent;
- FOnShow: TOnEvent;
- fOnEraseBkgnd: TOnPaint;
- {$ENDIF GDI}
- //----- order of following 3 events important: //
- fCaption: KOLString;
- fCustomData: Pointer;
- {$IFDEF GDI}
- fStatusTxt: PKOLChar;
- //---------------------------------------------//
- fCustomObj: PObj;
- fOnTVSelChanging: TOnTVSelChanging;
-
- fOnClose: TOnEventAccept;
- fOnQueryEndSession: TOnEventAccept;
- fCloseQueryReason: TCloseQueryReason;
-
- fShowAction: DWORD;
- //----- order of following 3 events important: //
- fOnMinimize: TOnEvent; //
- fOnMaximize: TOnEvent; //
- fOnRestore: TOnEvent; //
- //---------------------------------------------//
-
- //fCreateParamsExt: procedure( Self_: PControl; var Params: TCreateParams );
- fCreateWndExt: procedure( Sender: PControl );
-
- fTBevents: PList; // events for TBAssignEvents
- fTBBtnImgWidth: Integer; // custom toolbar bitmap width
- FTBBtMinWidth: Integer;
- FTBBtMaxWidth: Integer;
- fGradientStyle: TGradientStyle;
- fGradientLayout: TGradientLayout;
- fVisibleWoParent: Boolean;
-
- fTVRightClickSelect: Boolean;
- FOnMove: TOnEvent;
- FOnMoving: TOnEventMoving;
- FOnLVStateChange: TOnLVStateChange;
- fNotAvailable: Boolean;
- FPressedMnemonic: DWORD;
- FBitBtnDrawMnemonic: Boolean;
- FBitBtnGetCaption: function( Self_: PControl; const S: String ): String;
- FBitBtnExtDraw: procedure( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
- const CapText, CapTxtOrig: KOLString; Color: TColor );
- FTextShiftX, FTextShiftY: Integer;
- fNotifyChild: procedure( Self_, Child: PControl );
- fScrollChildren: procedure( Self_: PControl );
- fOnHelp: TOnHelp;
-
- FOnDTPUserString: TDTParseInputEvent;
- {$ifndef wince}
- fOnTBCustomDraw: TOnTBCustomDraw;
- {$endif wince}
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE var}
- {$I KOLMHToolTip.pas}
- {$UNDEF var}
-
- {$DEFINE function}
- {$I KOLMHToolTip.pas}
- {$UNDEF function}
- {$ENDIF}
-
- {$ENDIF GDI}
-
- procedure Init; {-}virtual;{+}{++}(*override;*){--}
- {* } //CLASSES //BCB_CLASSES
- {$IFDEF GDI}
- procedure InitParented( AParent: PControl ); virtual;
- {* Initialization of visual object. }
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure InitParented( AParent: PControl; widget: PGtkWidget;
- need_eventbox: Boolean ); virtual;
- {* Initialization of visual object. }
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- procedure DestroyChildren;
- {* Destroys children. Is called in destructor, and can be
- called in descending classes as earlier as needed to
- prevent problems of too late destroying of visuals.
- |<br>
- Note: since v 2.40, used only for case when a symbol NOT_USE_AUTOFREE4CONTROLS
- is defined, otherwise all children are destroyed using common mechanism of
- Add2AutoFree. }
-
- function GetParentWnd( NeedHandle: Boolean ): HWnd;
- {* Returns handle of parent window. }
- function GetParentWindow: HWnd;
- {* }
- procedure SetEnabled( Value: Boolean );
- {* Changes Enabled property value. Overriden here to change enabling
- status of a window. }
- function GetEnabled: Boolean;
- {* Returns True, if Enabled. Overriden here to obtain real window
- state. }
- procedure SetVisible( Value: Boolean );
- {* Sets Visible property value. Overriden here to change visibility
- of correspondent window. }
- procedure Set_Visible( Value: Boolean );
- {* }
- function GetVisible: Boolean;
- {* Returns True, if correspondent window is Visible. Overriden
- to get visibility of real window, not just value stored in object. }
- function Get_Visible: Boolean;
- {* Returns True, if correspondent window is Visible, for forms and applet,
- or if fVisible flag is set, for controls. }
- {$ENDIF GDI}
- procedure SetCtlColor( Value: TColor );
- {* Sets TControl's Color property value. }
- procedure SetBoundsRect( const Value: TRect );
- {* Sets BoudsRect property value. }
- function GetBoundsRect: TRect;
- {* Returns bounding rectangle. }
- {$IFDEF GDI}
- function GetIcon: HIcon;
- {* Returns Icon property. By default, if it is not set,
- returns Icon property of an Applet. }
-
- procedure CreateSubclass( var Params: TCreateParams; ControlClassName: PKOLChar );
- {* Can be used in descending classes to subclass window with given
- standard Windows ControlClassName - must be called after
- creating Params but before CreateWindow. Usually it is called
- in overriden method CreateParams after calling of the inherited one. }
-
- function UpdateWndStyles: PControl;
- {* Updates fStyle, fExStyle, fClsStyle from window handle }
- procedure SetOnChar(const Value: TOnChar);
- {* }
- {$IFDEF SUPPORT_ONDEADCHAR}
- procedure SetOnDeadChar(const Value: TOnChar);
- {* }
- {$ENDIF SUPPORT_ONDEADCHAR}
- procedure SetOnKeyDown(const Value: TOnKey);
- {* }
- procedure SetOnKeyUp(const Value: TOnKey);
- {* }
- {$ENDIF GDI}
- procedure SetOnMouseDown(const Value: TOnMouse);
- {* }
- procedure SetOnMouseMove(const Value: TOnMouse);
- {* }
- procedure SetOnMouseUp(const Value: TOnMouse);
- {* }
- procedure SetOnMouseWheel(const Value: TOnMouse);
- {* }
- procedure SetOnMouseDblClk(const Value: TOnMouse);
- {* }
- {$IFDEF GDI}
- procedure SetHelpContext( Value: Integer );
- {* }
- procedure SetOnTVDelete( const Value: TOnTVDelete );
- {* }
- procedure SetDefaultBtn(const Index: Integer; const Value: Boolean);
- {$IFDEF F_P}
- function GetDefaultBtn(const Index: Integer): Boolean;
- {$ENDIF F_P}
- function DefaultBtnProc( var Msg: TMsg; var Rslt: Integer ): Boolean;
- {* }
-
- procedure SetDateTime( Value: TDateTime );
- function GetDateTime: TDateTime;
- procedure SetDateTimeRange( Value: TDateTimeRange );
- function GetDateTimeRange: TDateTimeRange;
- procedure SetDateTimePickerColor( Index: TDateTimePickerColor; Value: TColor );
- function GetDateTimePickerColor( Index: TDateTimePickerColor ): TColor;
- procedure SetDateTimeFormat( const Value: KOLString );
- function Get_SystemTime: TSystemTime;
- procedure Set_SystemTime(const Value: TSystemTime);
- {$ifndef wince}
- procedure SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
- {$endif wince}
- {$ENDIF GDI}
- procedure DoAutoSize;
- function InternalProcessMessage(AMsg: PMsg): Boolean;
- public
- {$IFDEF GDI}
- constructor CreateParented( AParent: PControl );
- {* Creates new instance of TControl object, calling InitParented }
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- constructor CreateParented( AParent: PControl; widget: PGtkWidget;
- need_eventbox: Boolean );
- {* Creates new instance of TControl object, calling InitParented }
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* Destroyes object. First of all, destructors for all children
- are called. }
-
- function GetWindowHandle: HWnd;
- {* Returns window handle. If window is not yet created,
- method CreateWindow is called. }
- procedure CreateChildWindows;
- {* Enumerates all children recursively and calls CreateWindow for all
- of these. }
- {$ENDIF GDI}
- property Parent: PControl read fParent write SetParent;
- {* Parent of TParent object. Also must be of TParent type or derived from TParent. }
- //property Tag: Integer read FTag write FTag; //--------- moved to TObj --------
- {* User-defined pointer, which can contain any data or reference to
- anywhere in memory (when used as a pointer).
- }
- function ChildIndex( Child: PControl ): Integer;
- {* Returns index of given child. }
- procedure MoveChild( Child: PControl; NewIdx: Integer );
- {* Moves given Child into new position. }
-
- {$IFDEF GDI}
- property Enabled: Boolean read GetEnabled write SetEnabled;
- {* Enabled usually used to decide if control can get keyboard focus
- or been clicked by mouse. }
- procedure EnableChildren( Enable, Recursive: Boolean );
- {* Enables (Enable = TRUE) or disables (Enable = FALSE) all the children
- of the control. If Recursive = TRUE then all the children of all the
- children are enabled or disabled recursively. }
- property Visible: Boolean read Get_Visible write SetVisible;
- {* Obvious. }
- property ToBeVisible: Boolean read GetToBeVisible;
- {* Returns True, if a control is supposed to be visible when its
- form is showing. Thus is, True is returned if either control
- is Visible or hidden, but marked with flag fCreateHidden. }
- property CreateVisible: Boolean read fCreateVisible write fCreateVisible;
- {* False by default. If You want your form to be created visible and
- flick due creation, set it to True. This does not affect size of
- executable anyway. }
- property Align: TControlAlign read FAlign write Set_Align;
- {* Align style of a control. If this property is not used in your
- application, there are no additional code added. Aligning of
- controls is made in KOL like in VCL. To align controls when
- initially create ones, use "transparent" function SetAlign
- ("transparent" means that it returns @Self as a result).
- |<br>
- Note, that it is better not to align combobox caClient, caLeft or
- caRight (better way is to place a panel with Border = 0 and
- EdgeStyle = esNone, align it as desired and to place a combobox on it
- aligning caTop or caBottom). Otherwise, big problems could be under
- Win9x/Me, and some delay could occur under any other systems.
- |<br> Do not attempt to align some kinds of controls (like combobox)
- caLeft or caRight, this can cause infinite recursion. }
- {$ENDIF GDI}
- property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
- {* Bounding rectangle of the visual. Coordinates are relative
- to top left corner of parent's ClientRect, or to top left corner
- of screen (for TForm). }
- property Left: Integer read GetLeft write SetLeft;
- {* Left horizontal position. }
- property Top: Integer read GetTop write SetTop;
- {* Top vertical position. }
- property Width: Integer read GetWidth write SetWidth;
- {* Width of TVisual object. }
- property Height: Integer read GetHeight write SetHeight;
- {* Height of TVisual object. }
- property Position: TPoint read GetPosition write Set_Position;
- {* Represents top left position of the object. See also BoundsRect. }
- {$IFDEF GDI}
- property MinWidth: Integer index 0
- {$IFDEF F_P} read GetConstraint
- {$ELSE DELPHI} read FMinWidth
- {$ENDIF F_P/DELPHI} write SetConstraint;
- {* Minimal width constraint. }
- property MinHeight: Integer index 1
- {$IFDEF F_P} read GetConstraint
- {$ELSE DELPHI} read FMinHeight
- {$ENDIF F_P/DELPHI} write SetConstraint;
- {* Minimal height constraint. }
- property MaxWidth: Integer index 2
- {$IFDEF F_P} read GetConstraint
- {$ELSE DELPHI} read FMaxWidth
- {$ENDIF F_P/DELPHI} write SetConstraint;
- {* Maximal width constraint. }
- property MaxHeight: Integer index 3
- {$IFDEF F_P} read GetConstraint
- {$ELSE DELPHI} read FMaxHeight
- {$ENDIF F_P/DELPHI} write SetConstraint;
- {* Maximal height constraint. }
-
- {$ENDIF GDI}
- function ClientRect: TRect;
- {* Client rectangle of TControl. Contrary to VCL, for some
- classes (e.g. for graphic controls) can be relative
- not to itself, but to top left corner of the parent's ClientRect
- rectangle. }
- {$IFDEF GDI}
- property ClientWidth: Integer read GetClientWidth write SetClientWidth;
- {* Obvious. Accessing this property, program forces window latent creation. }
- property ClientHeight: Integer read GetClientHeight write SetClientHeight;
- {* Obvious. Accessing this property, program forces window latent creation. }
-
- function ControlRect: TRect;
- {* Absolute bounding rectangle relatively to nearest
- Windowed parent client rectangle (at least to a form, but usually to
- a Parent).
- Useful while drawing on device context, provided by such
- Windowed parent. For form itself is the same as BoundsRect. }
- function ControlAtPos( X, Y: Integer; IgnoreDisabled: Boolean ): PControl;
- {* Searches control at the given position (relatively to top left
- corner of the ClientRect). }
-
- {$ENDIF GDI}
- procedure Invalidate;
- {* Invalidates rectangle, occupied by the visual (but only if Showing =
- True). }
- {$IFDEF GDI}
- protected
- {$IFDEF USE_GRAPHCTLS}
- procedure InvalidateWindowed;
- procedure InvalidateNonWindowed;
- {$ENDIF}
- public
- procedure InvalidateEx;
- {* Invalidates the window and all its children. }
- procedure InvalidateNC( Recursive: Boolean );
- {* Invalidates the window and all its children including non-client area. }
- procedure Update;
- {* Updates control's window and calls Update for all child controls. }
- procedure BeginUpdate;
- {* |<#treeview>
- |<#listview>
- |<#richedit>
- |<#memo>
- |<#listbox>
- Call this method to stop visual updates of the control until correspondent
- EndUpdate called (pairs BeginUpdate - EndUpdate can be nested). }
- procedure EndUpdate;
- {* See BeginUpdate. }
-
- property Windowed: Boolean read fWindowed write fWindowed;
- {* Constantly returns True, if object is windowed (i.e. owns
- correspondent window handle). Otherwise, returns False.
- |<br>
- By now, all the controls are windowed (there are no controls in KOL, which are
- emulating window, acually belonging to Parent - like TGraphicControl
- in VCL).
- |<br>
- Writing of this property provided only for internal purposes,
- do not change it directly unless you understand well what you do. }
-
- function HandleAllocated: Boolean;
- {* Returns True, if window handle is allocated. Has no sense for
- non-Windowed objects (but now, the KOL has no non-Windowed controls). }
- property MDIClient: PControl read fMDIClient;
- {* For MDI forms only: returns MDI client window control, containng all MDI
- children. Use this window to send specific messages to rule MDI children. }
- {$ENDIF GDI}
-
- property ChildCount: Integer read GetChildCount;//GetChildCountWOMembers;
- {* Returns number of commonly accessed child objects (without
- MembersCount). }
- property Children[ Idx: Integer ]: PControl read GetMembers;
- {* Child items of TVisual object. Property is reintroduced here
- to separate access to always visible Children[] from restricted
- a bit Members[]. }
- {$IFDEF GDI}
- property MembersCount: Integer read FMembersCount;
- {* Returns number of "internal" child objects, which are
- not accessible through common Children[] property. }
- property Members[ Idx: Integer ]: PControl read GetMembers;
- {* Members and children array of the object (first from 0 to
- MembersCount-1 are Members[], and Children[] are followed by
- them. Usually You do not need to use this list. Use instead
- Children[0..ChildCount] property, Members[] is intended for
- internal needs of XCL (and in KOL by now Members and Children
- actually are the same properties). }
-
- procedure PaintBackground( DC: HDC; Rect: PRect );
- {* Is called to paint background in given rectangle. This
- method is filling clipped area of the Rect rectangle with
- Color, but only if global event Global_OnPaintBkgnd is
- not assigned. If assigned, this one is called instead here.
- |<br>
- This method made public, so it can be called directly to
- fill some device context's rectangle. But remember, that
- independantly of Rect, top left corner of background piece
- will be located so, if drawing is occure into ControlRect
- rectangle. }
- property WindowedParent: PControl read fParent;
- {* Returns nearest windowed parent, the same as Parent. }
- {$ENDIF GDI}
- function ParentForm: PControl;
- {* |<#form>
- Returns parent form for a control (of @Self for form itself. }
- {$IFDEF GDI}
- property ActiveControl: PControl read fCurrentControl write fCurrentControl;
- {* }
- function Client2Screen( const P: TPoint ): TPoint;
- {* Converts the client coordinates of a specified point to screen coordinates. }
- function Screen2Client( const P: TPoint ): TPoint;
- {* Converts screen coordinates of a specified point to client coordinates. }
- function CreateWindow: Boolean; virtual;
- {* |<#form>
- Creates correspondent window object. Returns True if success (if
- window is already created, False is returned). If applied to a form,
- all child controls also allocates handles that time.
- |<br>
- Call this method to ensure, that a hanle is allocated for a form,
- an application button or a control. (It is not necessary to do so in
- the most cases, even if You plan to work with control's handle directly.
- But immediately after creating the object, if You want to pass its
- handle to API function, this can be helpful). }
- {$ENDIF GDI}
- {$IFDEF _X_}
- procedure VisualizyWindow; // for _X_, makes actually visible a window and
- // all its subwindows recursively, if they are having Visible = TRUE
- {$ENDIF _X_}
- {$IFDEF GDI}
- procedure Close;
- {* |<#appbutton>
- |<#form>
- Closes window. If a window is the main form, this closes application,
- terminating it. Also it is possible to call Close method for Applet
- window to stop application. }
-
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE public}
- {$I KOLMHToolTip.pas}
- {$UNDEF public}
- {$ENDIF}
-
- property Handle: HWnd read fHandle; //GetHandle;
- {* Returns descriptor of system window object. If window is not yet
- created, 0 is returned. To allocate handle, call CreateWindow method. }
-
- property ParentWindow: HWnd read GetParentWindow;
- {* Returns handle of parent window (not TControl object, but system
- window object handle). }
- property ClsStyle: DWord read fClsStyle write SetClsStyle;
- {* Window class style. Available styles are:
- |<table border=0>
- |&L=<tr><td valign=top><font face=Fixedsys>%1</font></td><td>
- |&E=</td></tr>
- |&N=<br>
- <L CS_BYTEALIGNCLIENT> - Aligns the window's client area on the byte boundary
- (in the x direction) to enhance performance during
- drawing operations. <E>
- <L CS_BYTEALIGNWINDOW> - Aligns a window on a byte boundary (in the x
- direction). <E>
- <L CS_CLASSDC> - Allocates one device context to be shared by all
- windows in the class. <E>
- <L CS_DBLCLKS> - Sends double-click messages to the window
- procedure when the user double-clicks the mouse while the
- cursor is within a window belonging to the class. <E>
- <L CS_GLOBALCLASS> - Allows an application to create a window of
- the class regardless of the value of the hInstance parameter.
- <N> You can create a global class by creating
- the window class in a dynamic-link library (DLL) and listing the
- name of the DLL in the registry under specific keys. <E>
- <L CS_HREDRAW> - Redraws the entire window if a movement or
- size adjustment changes the width of the client area. <E>
- <L CS_NOCLOSE> - Disables the Close command on the System menu. <E>
- <L CS_OWNDC> - Allocates a unique device context for each window
- in the class. <E>
- <L CS_PARENTDC> - Sets the clipping region of the child window to
- that of the parent window so that the child can draw on the parent. <E>
- <L CS_SAVEBITS> - Saves, as a bitmap, the portion of the screen
- image obscured by a window. Windows uses the saved bitmap to re-create
- the screen image when the window is removed. <E>
- <L CS_VREDRAW> - Redraws the entire window if a movement or size
- adjustment changes the height of the client area. <E>
- |</table> For more info, see Win32.hlp (keyword 'WndClass');
- }
-
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- property edgeStyle : TEdgeStyle read fEdgeStyle write SetEdgeStyle;
- {$ENDIF}
-
- property Style: DWord read fStyle write SetStyle;
- {* Window styles. Available styles are:
- |<table border=0>
- <L WS_BORDER> Creates a window that has a thin-line border. <E>
- <L WS_CAPTION> Creates a window that has a title bar (includes the
- WS_BORDER style). <E>
- <L WS_CHILD> Creates a child window. This style cannot be used with
- the WS_POPUP style. <E>
- <L WS_CHILDWINDOW> Same as the WS_CHILD style. <E>
- <L WS_CLIPCHILDREN> Excludes the area occupied by child windows
- when drawing occurs within the parent window. This style is used
- when creating the parent window. <E>
- <L WS_CLIPSIBLINGS> Clips child windows relative to each other;
- that is, when a particular child window receives a WM_PAINT message,
- the WS_CLIPSIBLINGS style clips all other overlapping child windows
- out of the region of the child window to be updated. If
- WS_CLIPSIBLINGS is not specified and child windows overlap, it is
- possible, when drawing within the client area of a child window,
- to draw within the client area of a neighboring child window. <E>
- <L WS_DISABLED> Creates a window that is initially disabled. A
- disabled window cannot receive input from the user. <E>
- <L WS_DLGFRAME> Creates a window that has a border of a style
- typically used with dialog boxes. A window with this style cannot
- have a title bar. <E>
- <L WS_GROUP> Specifies the first control of a group of controls.
- The group consists of this first control and all controls defined
- after it, up to the next control with the WS_GROUP style.
- The first control in each group usually has the WS_TABSTOP
- style so that the user can move from group to group. The user
- can subsequently change the keyboard focus from one control in
- the group to the next control in the group by using the direction
- keys. <E>
- <L WS_HSCROLL> Creates a window that has a horizontal scroll bar. <E>
- <L WS_ICONIC> Creates a window that is initially minimized. Same as
- the WS_MINIMIZE style. <E>
- <L WS_MAXIMIZE> Creates a window that is initially maximized. <E>
- <L WS_MAXIMIZEBOX> Creates a window that has a Maximize button.
- Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
- style must also be specified. <E>
- <L WS_MINIMIZE> Creates a window that is initially minimized.
- Same as the WS_ICONIC style. <E>
- <L WS_MINIMIZEBOX> Creates a window that has a Minimize button.
- Cannot be combined with the WS_EX_CONTEXTHELP style. The WS_SYSMENU
- style must also be specified. <E>
- <L WS_OVERLAPPED> Creates an overlapped window. An overlapped
- window has a title bar and a border. Same as the WS_TILED style. <E>
- <L WS_OVERLAPPEDWINDOW> Creates an overlapped window with the
- WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME, WS_MINIMIZEBOX,
- and WS_MAXIMIZEBOX styles. Same as the WS_TILEDWINDOW style. <E>
- <L WS_POPUP> Creates a pop-up window. This style cannot be used with
- the WS_CHILD style. <E>
- <L WS_POPUPWINDOW> Creates a pop-up window with WS_BORDER,
- WS_POPUP, and WS_SYSMENU styles. The WS_CAPTION and WS_POPUPWINDOW
- styles must be combined to make the window menu visible. <E>
- <L WS_SIZEBOX> Creates a window that has a sizing border. Same as the
- WS_THICKFRAME style. <E>
- <L WS_SYSMENU> Creates a window that has a window-menu on its title
- bar. The WS_CAPTION style must also be specified. <E>
- <L WS_TABSTOP> Specifies a control that can receive the keyboard focus
- when the user presses the TAB key. Pressing the TAB key changes
- the keyboard focus to the next control with the WS_TABSTOP style. <E>
- <L WS_THICKFRAME> Creates a window that has a sizing border.
- Same as the WS_SIZEBOX style. <E>
- <L WS_TILED> Creates an overlapped window. An overlapped window has
- a title bar and a border. Same as the WS_OVERLAPPED style. <E>
- <L WS_TILEDWINDOW> Creates an overlapped window with the
- WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, WS_THICKFRAME,
- WS_MINIMIZEBOX, and WS_MAXIMIZEBOX styles. Same as the
- WS_OVERLAPPEDWINDOW style. <E>
- <L WS_VISIBLE> Creates a window that is initially visible. <E>
- <L WS_VSCROLL> Creates a window that has a vertical scroll bar. <E>
- |</table>
- See also Win32.hlp (topic CreateWindow).
- }
- property ExStyle: DWord read fExStyle write SetExStyle;
- {* Extra window styles. Available flags are following:
- |<table border=0>
- <L WS_EX_ACCEPTFILES> Specifies that a window created with this style
- accepts drag-drop files. <E>
- <L WS_EX_APPWINDOW> Forces a top-level window onto the taskbar
- when the window is minimized. <E>
- <L WS_EX_CLIENTEDGE> Specifies that a window has a border with a
- sunken edge. <E>
- <L WS_EX_CONTEXTHELP> Includes a question mark in the title bar of
- the window. When the user clicks the question mark, the cursor
- changes to a question mark with a pointer. If the user then clicks
- a child window, the child receives a WM_HELP message. The child
- window should pass the message to the parent window procedure,
- which should call the WinHelp function using the HELP_WM_HELP
- command. The Help application displays a pop-up window that
- typically contains help for the child window.WS_EX_CONTEXTHELP
- cannot be used with the WS_MAXIMIZEBOX or WS_MINIMIZEBOX styles. <E>
- <L WS_EX_CONTROLPARENT> Allows the user to navigate among the child
- windows of the window by using the TAB key. <E>
- <L WS_EX_DLGMODALFRAME> Creates a window that has a double border;
- the window can, optionally, be created with a title bar by
- specifying the WS_CAPTION style in the dwStyle parameter. <E>
- <L WS_EX_LEFT> Window has generic "left-aligned" properties. This
- is the default. <E>
- <L WS_EX_LEFTSCROLLBAR> If the shell language is Hebrew, Arabic, or
- another language that supports reading order alignment, the
- vertical scroll bar (if present) is to the left of the client
- area. For other languages, the style is ignored and not treated
- as an error. <E>
- <L WS_EX_LTRREADING> The window text is displayed using Left to
- Right reading-order properties. This is the default. <E>
- <L WS_EX_MDICHILD> Creates an MDI child window. <E>
- <L WS_EX_NOPARENTNOTIFY> Specifies that a child window created
- with this style does not send the WM_PARENTNOTIFY message to its
- parent window when it is created or destroyed. <E>
- <L WS_EX_OVERLAPPEDWINDOW> Combines the WS_EX_CLIENTEDGE and
- WS_EX_WINDOWEDGE styles. <E>
- <L WS_EX_PALETTEWINDOW> Combines the WS_EX_WINDOWEDGE,
- WS_EX_TOOLWINDOW, and WS_EX_TOPMOST styles. <E>
- <L WS_EX_RIGHT> Window has generic "right-aligned" properties.
- This depends on the window class. This style has an effect only
- if the shell language is Hebrew, Arabic, or another language that
- supports reading order alignment; otherwise, the style is
- ignored and not treated as an error. <E>
- <L WS_EX_RIGHTSCROLLBAR> Vertical scroll bar (if present) is to the
- right of the client area. This is the default. <E>
- <L WS_EX_RTLREADING> If the shell language is Hebrew, Arabic, or
- another language that supports reading order alignment, the
- window text is displayed using Right to Left reading-order
- properties. For other languages, the style is ignored and not
- treated as an error. <E>
- <L WS_EX_STATICEDGE> Creates a window with a three-dimensional
- border style intended to be used for items that do not accept
- user input. <E>
- <L WS_EX_TOOLWINDOW> Creates a tool window; that is, a window
- intended to be used as a floating toolbar. A tool window has
- a title bar that is shorter than a normal title bar, and the
- window title is drawn using a smaller font. A tool window does
- not appear in the taskbar or in the dialog that appears when
- the user presses ALT+TAB. <E>
- <L WS_EX_TOPMOST> Specifies that a window created with this style
- should be placed above all non-topmost windows and should stay
- above them, even when the window is deactivated. To add or remove
- this style, use the SetWindowPos function. <E>
- <L WS_EX_TRANSPARENT> Specifies that a window created with this
- style is to be transparent. That is, any windows that are
- beneath the window are not obscured by the window. A window
- created with this style receives WM_PAINT messages only after
- all sibling windows beneath it have been updated. <E>
- <L WS_EX_WINDOWEDGE> Specifies that a window has a border with
- a raised edge. <E>
- |</table>
- See also Win32.hlp (topic CreateWindowEx).
- }
-
- property Cursor: HCursor read fCursor write SetCursor;
- {* Current cursor. For most of controls, sets initially to IDC_ARROW. See
- also ScreenCursor. }
- procedure CursorLoad( Inst: Integer; ResName: PKOLChar );
- {* Loads Cursor from the resource. See also comments for Icon property. }
-
- property Icon: HIcon read {$IFDEF SMALLEST_CODE} fIcon {$ELSE} GetIcon {$ENDIF}
- write SetIcon;
- {* |<#appbutton>
- |<#form>
- Icon. By default, icon of the Applet is used. To load icon from the
- resource, use IconLoad or IconLoadCursor method - this is more correct, because
- in such case a special flag is set to prevent attempts to destroy
- shared icon object in the destructor of the control. }
-
- procedure IconLoad( Inst: Integer; ResName: PKOLChar );
- {* |<#appbutton>
- |<#form>
- See Icon property. }
- procedure IconLoadCursor( Inst: Integer; ResName: PKOLChar );
- {* |<#appbutton>
- |<#form>
- Loads Icon from the cursor resource. See also Icon property. }
-
- property Menu: HMenu read fMenu write SetMenu;
-
- {* Menu (or ID of control - for standard GUI controls). }
- property HelpContext: Integer read fHelpContext write SetHelpContext;
- {* Help context. }
- function AssignHelpContext( Context: Integer ): PControl;
- {* Assigns HelpContext and returns @ Self (can be used in initialization
- of a control in a chain of "transparent" calls). }
-
- procedure CallHelp( Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
- {* Method of a form or Applet. Call it to show help with the given context
- ID. If the Context = 0, help contents is displayed. By default,
- WinHelp is used. To allow using HtmlHelp, call AssignHtmlHelp global
- function. When WinHelp used, HelpPath variable can be assigned directly.
- If HelpPath variable is not assigned, application name
- (and path) is used, with extension replaced to '.hlp'. }
-
- property HelpPath: KOLString read GetHelpPath write SetHelpPath;
- {* Property of a form or an Applet. Change it to provide custom path to
- WinHelp format help file. If HtmlHelp used, call global procedure
- AssignHtmlHelp instead. }
-
- property OnHelp: TOnHelp read fOnHelp write fOnHelp;
- {* An event of a form, it is called when F1 pressed or help topic requested
- by any other way. To prevent showing help, nullify Sender. Set Popup to
- TRUE to provide showing help in a pop-up window. It is also possible to
- change Context dynamically. }
-
- {$ENDIF GDI}
- property Caption: KOLString read GetCaption write SetCaption;
- {* |<#appbutton>
- |<#form>
- |<#button>
- |<#bitbtn>
- |<#label>
- |<#wwlabel>
- |<#3dlabel>
- Caption of a window. For standard Windows buttons, labels and so on
- not a caption of a window, but text of the window. }
- property Text: KOLString read GetCaption write SetCaption;
- {* |<#edit>
- |<#memo>
- The same as Caption. To make more convenient with Edit controls. For
- Rich Edit control, use property RE_Text. }
-
- {$IFDEF GDI}
- property SelStart: Integer read GetSelStart write SetSelStart;
- {* |<#edit>
- |<#memo>
- |<#richedit>
- Start of selection (editbox - character position). }
- property SelLength: Integer read GetSelLength write SetSelLength;
- {* |<#edit>
- |<#memo>
- |<#richedit>
- |<#listbox>
- |<#listview>
- Length of selection (editbox - number of characters selected, multiselect
- listbox or listview - number of items selected).
- |<br>
- Note, that for combobox and single-select listbox it always returns 0
- (though for single-select listview, returns 1, if there is an item
- selected).
- |<br>
- It is possible to set SelLength only for memo and richedit controls. }
-
- property Selection: KOLString read GetSelection write SetSelection;
- {* |<#edit>
- |<#memo>
- |<#richedit>
- Selected text (editbox, richedit) as string. Can be useful to replace
- selection. For rich edit, use RE_Text[ reText, TRUE ], if you want to
- read correctly characters from another locale then ANSI only. }
- procedure SelectAll;
- {* |<#edit>
- |<#memo>
- |<#richedit>
- Makes all the text in editbox or RichEdit, or all items in listbox
- selected. }
-
- procedure ReplaceSelection( const Value: KOLString; aCanUndo: Boolean );
- {* |<#edit>
- |<#memo>
- |<#richedit>
- Replaces selection (in edit, RichEdit). Unlike assigning new value
- to Selection property, it is possible to specify, if operation can
- be undone. }
-
- procedure DeleteLines( FromLine, ToLine: Integer );
- {* |<#edit>
- |<#memo>
- |<#richedit>
- Deletes lines from FromLine to ToLine (inclusively, i.e. 0 to 0 deletes
- one line with index 0). Current selection is restored as possible. }
- property CurIndex: Integer read GetCurIndex write SetCurIndex;
- {* |<#listbox>
- |<#combo>
- |<#toolbar>
- Index of current item (for listbox, combobox) or button index pressed
- or dropped down (for toolbar button, and only in appropriate event
- handler call).
- |<br>
- You cannot use it to set or remove a selection in a multiple-selection
- list box, so you should set option loNoExtendSel to true.
- |<br>
- In OnClick event handler, CurIndex has not yet changed for listbox or combobox.
- Use OnSelChange to respond to selection changes. }
-
- property Count: Integer read GetItemsCount write SetItemsCount;
- {* |<#listbox>
- |<#combo>
- |<#listview>
- |<#treeview>
- |<#edit>
- |<#memo>
- |<#richedit>
- |<#toolbar>
- Number of items (listbox, combobox, listview) or lines (multiline
- editbox, richedit control) or buttons (toolbar). It is possible to
- assign a value to this property only for listbox control with loNoData
- style and for list view control with lvoOwnerData style (virtual list
- box and list view). }
-
- property Items[ Idx: Integer ]: KOLString read GetItems write SetItems;
- {* |<#edit>
- |<#listbox>
- |<#combo>
- |<#memo>
- |<#richedit>
- Obvious. Used with editboxes, listbox, combobox. With list view, use
- property LVItems instead. }
-
- function Item2Pos( ItemIdx: Integer ): DWORD;
- {* |<#edit>
- |<#memo>
- Only for edit controls: converts line index to character position. }
- function Pos2Item( Pos: Integer ): DWORD;
- {* |<#edit>
- |<#memo>
- Only for edit controls: converts character position to line index. }
-
- function SavePosition: TEditPositions;
- {* |<#edit>
- |<#memo>
- Only for edit controls: saves current editor selection and scroll
- positions. To restore position, use RestorePosition with a structure,
- containing saved position as a parameter. }
- procedure RestorePosition( const p: TEditPositions );
- {* |<#edit>
- |<#memo>
- Call RestorePosition with a structure, containing saved position
- as a parameter (this structure filled in in SavePosition method).
- If you set RestoreScroll to FALSE, only selection is restored,
- without scroll position. }
- procedure UpdatePosition( var p: TEditPositions; FromPos,
- CountInsertDelChars, CountInsertDelLines: Integer );
- {* |<#edit>
- |<#memo>
- If you called SavePosition and then make some changes in the edit control,
- calling RestorePosition will fail if chages are affecting selection size.
- The problem can be solved updating saved position info using this method.
- Pass a count of inserted characters and lines as a positive number and a
- count of deleted characters as a negative number here. CountInsertDelLines
- is optional paramters: if you do not specify it, only selection is fixed.
- }
-
- function EditTabChar: PControl;
- {* |<#edit>
- |<#memo>
- Call this method (once) to provide insertion of tab character (code #9)
- when tab key is pressed on keyboard. }
-
- function IndexOf( const S: KOLString ): Integer;
- {* |<#listbox>
- |<#combobox>
- |<#tabcontrol>
- Works for the most of control types, though some of those
- have its own methods to search given item. If a control is not
- list box or combobox, item is finding by enumerating all
- the Items one by one. See also SearchFor method. }
- function SearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
- {* |<#listbox>
- |<#combobox>
- |<#tabcontrol>
- Works for the most of control types, though some of those
- have its own methods to search given item. If a control is not
- list box or combobox, item is finding by enumerating all
- the Items one by one. See also IndexOf method. }
-
- property ItemSelected[ ItemIdx: Integer ]: Boolean read GetItemSelected write SetItemSelected;
- {* |<#edit>
- |<#memo>
- |<#listbox>
- |<#combo>
- |<#listview>
- Returns True, if a line (in editbox) or an item (in listbox, combobox,
- listview) is selected.
- Can be set only for listboxes. For listboxes, which are not multiselect, and
- for combo lists, it is possible only to set to True, to change selection. }
-
- property ItemData[ Idx: Integer ]: DWORD read GetItemData write SetItemData;
- {* |<#listbox>
- |<#combo>
- Access to user-defined data, associated with the item of a list box and
- combo box. }
- property OnDropDown: TOnEvent read fOnDropDown write fOnDropDown;
- {* |<#combo>
- |<#toolbar>
- Is called when combobox is dropped down (or drop-down button of
- toolbar is pressed - see also OnTBDropDown). }
- property OnCloseUp: TOnEvent read fOnCloseUp write fOnCloseUp;
- {* |<#combo>
- Is called when combobox is closed up. When drop down list is closed
- because user pressed "Escape" key, previous selection is restored.
- To test if it is so, call GetKeyState( VK_ESCAPE ) and check, if
- negative value is returned (i.e. Escape key is pressed when event
- handler is calling). }
- property DroppedWidth: Integer read FDroppedWidth write SetDroppedWidth;
- {* |<#combo>
- Allows to change width of dropped down items list for combobox (only!)
- control. }
- property DroppedDown: Boolean read fDropped write SetDroppedDown;
- {* |<#combo>
- Dropped down state for combo box. Set it to TRUE or FALSE to change
- dropped down state. }
- procedure AddDirList( const Filemask: KOLString; Attrs: DWORD );
- {* |<#listbox>
- |<#combo>
- Can be used only with listbox and combobox - to add directory list items,
- filtered by given Filemask (can contain wildcards) and Attrs. Following
- flags can be combined in Attrs:
- |<table border=0>
- |&L=<tr><td>%1</td><td>
- <L DDL_ARCHIVE> Include archived files. <E>
- <L DDL_DIRECTORY> Includes subdirectories. Subdirectory names are
- enclosed in square brackets ([ ]). <E>
- <L DDL_DRIVES> Includes drives. Drives are listed in the form [-x-],
- where x is the drive letter. <E>
- <L DDL_EXCLUSIVE> Includes only files with the specified attributes.
- By default, read-write files are listed even if DDL_READWRITE is
- not specified. Also, this flag needed to list directories only,
- etc. <E>
- <L DDL_HIDDEN> Includes hidden files. <E>
- <L DDL_READONLY> Includes read-only files. <E>
- <L DDL_READWRITE> Includes read-write files with no additional
- attributes. <E>
- <L DDL_SYSTEM> Includes system files. <E>
- </table>
- If the listbox is sorted, directory items will be sorted (alpabetically). }
- property OnBitBtnDraw: TOnBitBtnDraw read fOnBitBtnDraw write fOnBitBtnDraw;
- {* |<#bitbtn>
- Special event for BitBtn. Using it, it is possible to provide
- additional effects, such as highlighting button text (by changing
- its Font and other properties). If the handler returns True, it is
- supposed that it made all drawing and there are no further drawing
- occure. }
- property BitBtnDrawMnemonic: Boolean read FBitBtnDrawMnemonic write SetBitBtnDrawMnemonic;
- {* |<#bitbtn>
- Set this property to TRUE to provide correct drawing of bit btn control
- caption with '&' characters (to remove such characters, and underline
- follow ones). }
- property TextShiftX: Integer read fTextShiftX write fTextShiftX;
- {* |<#bitbtn>
- Horizontal shift for bitbtn text when the bitbtn is pressed. }
- property TextShiftY: Integer read fTextShiftY write fTextShiftY;
- {* |<#bitbtn>
- Vertical shift for bitbtn text when the bitbtn is pressed. }
- property BitBtnImgIdx: Integer read GetBitBtnImgIdx write SetBitBtnImgIdx;
- {* |<#bitbtn>
- BitBtn image index for the first image in list view, used as bitbtn
- image. It is used only in case when BitBtn is created with bboImageList
- option. }
- property BitBtnImgList: THandle read GetBitBtnImageList write SetBitBtnImageList;
- {* |<#bitbtn>
- BitBtn Image list. Assign image list handle to change it. }
-
- function SetButtonIcon( aIcon: HIcon ): PControl;
- {* |<#button>
- Sets up button icon image and changes its styles. Returns button itself. }
- function SetButtonBitmap( aBmp: HBitmap ): PControl;
- {* |<#button>
- Sets up button icon image and changes its styles. Returns button itself. }
-
- property OnMeasureItem: TOnMeasureItem read fOnMeasureItem write SetOnMeasureItem;
- {* |<#combo>
- |<#listbox>
- |<#listview>
- This event is called for owner-drawn controls, such as list box, combo box,
- list view with appropriate owner-drawn style. For fixed item height controls
- (list box with loOwnerDrawFixed style, combobox with coOwnerDrawFixed and
- list view with lvoOwnerDrawFixed option) this event is called once. For
- list box with loOwnerDrawVariable style and for combobox with coOwnerDrawVariable
- style this event is called for every item. }
-
- property DefaultBtn: Boolean index 13
- {$IFDEF F_P} read GetDefaultBtn
- {$ELSE DELPHI} read fDefaultBtn
- {$ENDIF F_P/DELPHI} write SetDefaultBtn;
- {* |<#button>
- |<#bitbtn>
- Set this property to true to make control clicked when ENTER key is pressed.
- This property uses OnMessage event of the parent form, storing it into
- fOldOnMessage field and calling in chain. So, assign default button
- after setting OnMessage event for the form. }
- property CancelBtn: Boolean index 27
- {$IFDEF F_P} read GetDefaultBtn
- {$ELSE DELPHI} read fCancelBtn
- {$ENDIF F_P/DELPHI} write SetDefaultBtn;
- {* |<#button>
- |<#bitbtn>
- Set this property to true to make control clicked when escape key is pressed.
- This property uses OnMessage event of the parent form, storing it into
- fOldOnMessage field and calling in chain. So, assign cancel button
- after setting OnMessage event for the form. }
- function AllBtnReturnClick: PControl;
- {* Call this method for a form or any its control to provide clicking
- a focused button when ENTER pressed. By default, a button can be clicked
- only by SPACE key from the keyboard, or by mouse. }
- property IgnoreDefault: Boolean read fIgnoreDefault write fIgnoreDefault;
- {* Change this property to TRUE to ignore default button reaction on
- press ENTER key when a focus is grabbed of the control. Default
- value is different for different controls. By default, DefaultBtn
- ignored in memo, richedit (even if read-only). }
-
- {$ENDIF GDI}
- property Color: TColor read fColor write SetCtlColor;
- {* Property Color is one of the most common for all visual
- elements (like form, control etc.) Please note, that standard GUI button
- can not change its color and the most characteristics of the Font. Also,
- standard button can not become Transparent. Use bitbtn for such purposes.
- Also, changing Color property for some kinds of control has no effect (rich edit,
- list view, tree view, etc.). To solve this, use native (for such controls)
- color property, or call Perform method with appropriate message to set the
- background color. }
- property Font: PGraphicTool read GetFont;
- {* If the Font property is not accessed, correspondent TGraphicTool object
- is not created and its methods are not included into executable. Leaving
- properties Font and Brush untouched can economy executable size a lot. }
- {$IFDEF GDI}
- property Brush: PGraphicTool read GetBrush;
- {* If not accessed, correspondent TGraphicTool object is not created
- and its methods are not referenced. See also note on Font property. }
-
- property Ctl3D: Boolean read fCtl3D write SetCtl3D;
- {* Inheritable from parent controls to child ones. }
-
- procedure Show;
- {* |<#appbutton>
- |<#form>
- Makes control visible and activates it. }
- function ShowModal: Integer;
- {* |<#form>
- Can be used only with a forms to show it modal. See also global function
- ShowMsgModal.
- |<br>
- To use a form as a modal, it is possible to make it either auto-created
- or dynamically created. For a first case, You (may be prefer to hide a
- form after showing it as a modal:
- !
- ! procedure TForm1.Button1Click( Sender: PObj );
- ! begin
- ! Form2.Form.ShowModal;
- ! Form2.Form.Hide;
- ! end;
- !
- Another way is to create modal form just before showing it (this economies
- system resources):
- !
- ! procedure TForm1.Button1Click( Sender: PObj );
- ! begin
- ! NewForm2( Form2, Applet );
- ! Form2.Form.ShowModal;
- ! Form2.Form.Free; // Never call Form2.Free or Form2.Form.Close
- ! end; // but always Form2.Form.Free; (!)
- !
- In samples above, You certainly can place any wished code before and after
- calling ShowModal method.
- |<br>
- Do not forget that if You have more than a single form in your project,
- separate Applet object should be used.
- |<br>
- See also ShowModalEx.
- }
- function ShowModalParented( const AParent: PControl ): Integer;
- {* by Alexander Pravdin. The same as ShowModal, but with a certain
- form as a parent. }
- function ShowModalEx: Integer;
- {* The same as ShowModal, but all the windows of current thread are
- disabled while showing form modal. This is useful if KOL form from
- a DLL is used modally in non-KOL application. }
- property ModalResult: Integer read fModalResult write
- {$IFDEF USE_SETMODALRESULT}
- SetModalResult;
- {$ELSE}
- fModalResult;
- {$ENDIF}
- {* |<#form>
- Modal result. Set it to value<>0 to stop modal dialog. By agreement,
- value 1 corresponds 'OK', 2 - 'Cancel'. But it is totally by decision
- of yours how to interpret this value. }
- property Modal: Boolean read GetModal;
- {* |<#form>
- TRUE, if the form is shown modal. }
- property ModalForm: PControl read fModalForm write fModalForm;
- {* |<#form>
- |<#appbutton>
- Form currently shown modal from this form or from Applet. }
-
- procedure Hide;
- {* |<#appbutton>
- |<#form>
- Makes control hidden. }
- property OnShow: TOnEvent read FOnShow write SetOnShow;
- {* Is called when a control or form is to be shown. This event is not fired
- for a form, if its WindowState initially is set to wsMaximized or
- wsMinimized. This behaviour is by design (the window does not receive
- WM_SHOW message in such case). }
- property OnHide: TOnEvent read FOnHide write SetOnHide;
- {* Is called when a control or form becomes hidden. }
- property WindowState: TWindowState read GetWindowState write SetWindowState;
- {* |<#form>
- Window state. }
-
- {$ENDIF GDI}
- property Canvas: PCanvas read GetCanvas;
- {* |<#paintbox>
- Placeholder for Canvas: PCanvas. But in KOL, it is possible to
- create applets without canvases at all. To do so, avoid using
- Canvas and use DC directly (which is passed in OnPaint event). }
- {$IFDEF GDI}
- function CallDefWndProc( var Msg: TMsg ): Integer;
- {* Function to be called in WndProc method to redirect message handling
- to default window procedure. }
- function DoSetFocus: Boolean;
- {* Sets focus for Enabled window. Returns True, if success. }
-
- procedure MinimizeNormalAnimated;
- {* |<#form>
- Apply this method to a main form (not to another form or Applet,
- even when separate Applet control is not used and main form matches it!).
- This provides normal animated visual minimization for the application.
- It therefore has no effect, if animation during minimize/resore is
- turned off by user.
- |<br>
- Applying this method also provides for the main form (only for it)
- correct restoring the form maximized if it was maximized while
- minimizing the application. See also RestoreNormalMaximized method. }
- procedure RestoreNormalMaximized;
- {* |<#form>
- Apply to any form for which it is important to restore it maximized
- when the application was minimizing while such form was maximized.
- If the method MinimizeNormalAnimated was called for the main form,
- then the correct behaviour is already provided for the main form, so
- in such case it is no more necessary to call also this method, but
- calling it therefore is not an error. }
-
- property OnMessage: TOnMessage read fOnMessage write fOnMessage;
- {* |<#appbutton>
- |<#form>
- Is called for every message processed by TControl object. And for
- Applet window, this event is called also for all messages, handled by
- all its child windows (forms). }
-
- {$ENDIF GDI}
- function IsMainWindow: Boolean;
- {* |<#appbutton>
- |<#form>
- Returns True, if a window is the main in application (created first
- after the Applet, or matches the Applet). }
- property IsApplet: Boolean read FIsApplet;
- {* Returns true, if the control is created using NewApplet (or CreateApplet).
- }
- property IsForm: Boolean read fIsForm;
- {* Returns True, if the object is form window. }
- property IsMDIChild: Boolean read fIsMDIChild;
- {* Returns TRUE, if the object is MDI child form. In such case, IsForm also
- returns TRUE. }
- property IsControl: Boolean read fIsControl;
- {* Returns True, is the control is control (not form or applet). }
- property IsButton: Boolean read fIsButton;
- {* Returns True, if the control is button-like or containing buttons (button,
- bitbtn, checkbox, radiobox, toolbar). }
-
- {$IFDEF GDI}
- function ProcessMessage: Boolean;
- {* |<#appbutton>
- Processes one message. See also ProcessMessages. }
-
- procedure ProcessMessages;
- {* |<#appbutton>
- Processes pending messages during long cycle of calculation,
- allowing to window to be repainted if needed and to respond to other
- messages. But if there are no such messages, your application can be
- stopped until such one appear in messages queue. To prevent such
- situation, use method ProcessPendingMessages instead. }
-
- procedure ProcessMessagesEx;
- {* Version of ProcessMessages, which works always correctly, even if
- the application is minimized or background. }
-
- procedure ProcessPendingMessages;
- {* |<#appbutton>
- Similar to ProcessMessages, but without waiting of
- message in messages queue. I.e., if there are no pending
- messages, this method immediately returns control to your
- code. This method is better to call during long cycle of
- calculation (then ProcessMessages). }
- procedure ProcessPaintMessages;
- {* }
- procedure WaitAndProcessMessages;
- {* }
- function WndProc( var Msg: TMsg ): Integer; virtual; //{$IFNDEF DEBUG_MCK} virtual; {$ENDIF}
- {* Responds to all Windows messages, posted (sended) to the
- window, before all other proceeding. You can override it in
- derived controls, but in KOL there are several other ways
- to control message flow of existing controls without deriving
- another costom controls for only such purposes. See OnMessage,
- AttachProc. }
- property HasBorder: Boolean read GetHasBorder write SetHasBorder;
- {* |<#form>
- Obvious. Form-aware. }
-
- property HasCaption: Boolean read GetHasCaption write SetHasCaption;
- {* |<#form>
- Obvious. Form-aware. }
- property CanResize: Boolean read GetCanResize write SetCanResize;
- {* |<#form>
- Obvious. Form-aware. }
- property StayOnTop: Boolean read GetStayOnTop write SetStayOnTop;
- {* |<#form>
- Obvious. Form-aware, but can be applied to controls. }
- property Border: Integer read fMargin write fMargin;
- {* |<#form>
- Distance between edges and child controls and between child
- controls by default (if methods PlaceRight, PlaceDown, PlaceUnder,
- ResizeParent, ResizeParentRight, ResizeParentBottom are called).
- |<br>
- Originally was named Margin, now I recommend to use the name 'Border' to
- avoid confusion with MarginTop, MarginBottom, MarginLeft and
- MarginRight properties.
- |<br>
- Initial value is always 2. Border property is used in realigning
- child controls (when its Align property is not caNone), and value
- of this property determines size of borders between edges of children
- and its parent and between aligned controls too.
- |<br>
- See also properties MarginLeft, MarginRight, MarginTop, MarginBottom. }
- function SetBorder( Value: Integer ): PControl;
- {* Assigns new Border value, and returns @ Self. }
-
- property Margin: Integer read fMargin write fMargin;
- {* |<#form>
- Old name for property Border. }
-
- property MarginTop: Integer index 1
- {$IFDEF F_P} read GetClientMargin
- {$ELSE DELPHI} read fClientTop
- {$ENDIF F_P/DELPHI} write SetClientMargin;
- {* Additional distance between true window client top and logical top of
- client rectangle. This value is added to Top of rectangle, returning
- by property ClientRect. Together with other margins and property Border,
- this property allows to change view of form for case, that Align property
- is used to align controls on parent (it is possible to provide some
- distance from child controls to its parent, and between child controls.
- |<br>
- Originally this property was introduced to compensate incorrect
- ClientRect property, calculated for some types of controls.
- |<br>
- See also properties Border, MarginBottom, MarginLeft, MarginRight. }
- property MarginBottom: Integer index 2
- {$IFDEF F_P} read GetClientMargin
- {$ELSE DELPHI} read fClientBottom
- {$ENDIF F_P/DELPHI} write SetClientMargin;
- {* The same as MarginTop, but a distance between true window Bottom of
- client rectangle and logical bottom one. Take in attention, that this value
- should be POSITIVE to make logical bottom edge located above true edge.
- |<br>
- See also properties Border, MarginTop, MarginLeft, MarginRight. }
- property MarginLeft: Integer index 3
- {$IFDEF F_P} read GetClientMargin
- {$ELSE DELPHI} read fClientLeft
- {$ENDIF F_P/DELPHI} write SetClientMargin;
- {* The same as MarginTop, but a distance between true window Left of
- client rectangle and logical left edge.
- |<br>
- See also properties Border, MarginTop, MarginRight, MarginBottom. }
- property MarginRight: Integer index 4
- {$IFDEF F_P} read GetClientMargin
- {$ELSE DELPHI} read fClientRight
- {$ENDIF F_P/DELPHI} write SetClientMargin;
- {* The same as MarginLeft, but a distance between true window Right of
- client rectangle and logical bottom one. Take in attention, that this value
- should be POSITIVE to make logical right edge located left of true edge.
- |<br>
- See also properties Border, MarginTop, MarginLeft, MarginBottom. }
-
- property Tabstop: Boolean read fTabstop write fTabstop;
- {* True, if control can be focused using tabulating between controls.
- Set it to False to make control unavailable for keyboard, but only
- for mouse. }
-
- property TabOrder: Integer read fTabOrder write SetTabOrder;
- {* Order of tabulating of controls. Initially, TabOrder is equal to
- creation order of controls. If TabOrder changed, TabOrder of
- all controls with not less value of one is shifted up. To place
- control before another, assign TabOrder of one to another.
- For example:
- ! Button1.TabOrder := EditBox1.TabOrder;
- In code above, Button1 is placed just before EditBox1 in tabulating
- order (value of TabOrder of EditBox1 is incremented, as well as
- for all follow controls). }
-
- property Focused: Boolean read GetFocused write SetFocused;
- {* True, if the control is current on form (but check also, what form
- itself is focused). For form it is True, if the form is active (i.e.
- it is foreground and capture keyboard). Set this value to True to make
- control current and focused (if applicable). }
-
- function BringToFront: PControl;
- {* Changes z-order of the control, bringing it to the topmost level. }
- function SendToBack: PControl;
- {* Changes z-order of the control, sending it to the back of siblings. }
- {$ENDIF GDI}
- property TextAlign: TTextAlign read GetTextAlign write SetTextAlign;
- {* |<#label>
- |<#panel>
- |<#button>
- |<#bitbtn>
- |<#edit>
- |<#memo>
- Text horizontal alignment. Applicable to labels, buttons,
- multi-line edit boxes, panels. }
- property VerticalAlign: TVerticalAlign read GetVerticalAlign write SetVerticalAlign;
- {* |<#button>
- |<#label>
- |<#panel>
- Text vertical alignment. Applicable to buttons, labels and panels. }
- {$IFDEF GDI}
- property WordWrap: Boolean read fWordWrap write fWordWrap;
- {* TRUE, if this is a label, created using NewWordWrapLabel. }
- property ShadowDeep: Integer read FShadowDeep write SetShadowDeep;
- {* |<#3dlabel>
- Deep of a shadow (for label effect only, created calling NewLabelEffect). }
-
- property CannotDoubleBuf: Boolean read fCannotDoubleBuf write fCannotDoubleBuf;
- {* }
- property DoubleBuffered: Boolean read fDoubleBuffered write SetDoubleBuffered;
- {* Set it to true for some controls, which are flickering in repainting
- (like label effect). Slow, and requires additional code. This property
- is inherited by all child controls.
- |<br>
- Note: RichEdit control can not become DoubleBuffered. }
- function DblBufTopParent: PControl;
- {* Returns the topmost DoubleBuffered Parent control. }
- property Transparent: Boolean read fTransparent write SetTransparent;
- {* Set it to true to get special effects. Transparency also uses
- DoubleBuffered and inherited by child controls.
- |<br>
- Please note, that some controls can not be shown properly, when
- Transparent is set to True for it. If You want to make edit control
- transparent (e.g., over gradient filled panel), handle its OnChanged
- property and call there Invalidate to provide repainting of edit
- control content. Note also, that for RichEdit control property
- Transparent has no effect (as well as DoubleBuffered). But special
- property RE_Transparent is designed especially for RichEdit control
- (it works fine, but with great number of flicks while resizing
- of a control). Another note is about Edit control. To allow editing
- of transparent edit box, it is necessary to invalidate it for
- every pressed character. Or, use Ed_Transparent property instead. }
- property Ed_Transparent: Boolean read fTransparent write EdSetTransparent;
- {* |<#edit>
- |<#memo>
- Use this property for editbox to make it really Transparent. Remember,
- that though Transparent property is inherited by child controls from
- its parent, this is not so for Ed_Transparent. So, it is necessary to
- set Ed_Transparent to True for every edit control explicitly. }
- property AlphaBlend: Integer read fAlphaBlend write SetAlphaBlend;
- {* |<#form>
- If assigned to 0..254, makes window (form or control) semi-transparent
- (Win2K only).
- |<br>
- Depending on value assigned, it is possible to adjust transparency
- level ( 0 - totally transparent, 255 - totally opaque). }
- function MouseTransparent: PControl;
- {* Call this method to set up mouse transparent control (which always
- returns HTTRANSPARENT in responce to WM_NCHITTEST). This function
- returns a pointer to a control itself. }
-
- property LookTabKeys: TTabKeys read fLookTabKeys write fLookTabKeys;
- {* Set of keys which can be used as tabulation keys in a control. }
- procedure GotoControl( Key: DWORD );
- {* |<#form>
- Emulates tabulation key press w/o sending message to current control.
- Can be applied to a form or to any its control. If VK_TAB is used,
- state of shift kay is checked in: if it is pressed, tabulate is in
- backward direction. }
- property SubClassName: KOLString read get_ClassName write set_ClassName;
- {* Name of window class - unique for every window class
- in every run session of a program. }
-
- protected
- procedure SetOnClose( const AOnClose: TOnEventAccept );
- procedure SetFormOnClick( const AOnClick: TOnEvent );
- public
- property OnClose: TOnEventAccept read fOnClose write SetOnClose;
- {* |<#form>
- |<#applet>
- Called before closing the window. It is possible to set Accept
- parameter to False to prevent closing the window. This event events
- is not called when windows session is finishing (to handle this
- event, handle WM_QUERYENDSESSION message, or assign OnQueryEndSession
- event to another or the same event handler). }
-
- property OnQueryEndSession: TOnEventAccept read fOnQueryEndSession write SetOnQueryEndSession;
- {* |<#form>
- |<#applet>
- Called when WM_QUERYENDSESSION message come in. It is possible to set Accept
- parameter to False to prevent closing the window (in such case session ending
- is halted). It is possible to check CloseQueryReason property to find out,
- why event occur.
- |<br>
- To provide normal application close while handling OnQueryEndSession,
- call in your code PostQuitMessage( 0 ) or call method Close for the main form,
- this is enough to provide all OnClose and OnDestroy handlers to be called. }
- property CloseQueryReason: TCloseQueryReason read fCloseQueryReason;
- {* Reason why OnClose or OnQueryEndSession called. }
- property OnMinimize: TOnEvent index 0
- {$IFDEF F_P} read GetOnMinMaxRestore
- {$ELSE DELPHI} read fOnMinimize
- {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
- {* |<#form>
- Called when window is minimized. }
- property OnMaximize: TOnEvent index 8
- {$IFDEF F_P} read GetOnMinMaxRestore
- {$ELSE DELPHI} read fOnMaximize
- {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
- {* |<#form>
- Called when window is maximized. }
- property OnRestore: TOnEvent index 16
- {$IFDEF F_P} read GetOnMinMaxRestore
- {$ELSE DELPHI} read fOnRestore
- {$ENDIF F_P/DELPHI} write SetOnMinMaxRestore;
- {* |<#form>
- Called when window is restored from minimized or maximized state. }
-
- property UpdateRgn: HRgn read fUpdRgn;
- {* A handle of update region. Valid only in OnPaint method. You
- can use it to improve painting (for speed), if necessary. When
- UpdateRgn is obtained in response to WM_PAINT message, value
- of the property EraseBackground is used to pass it to the API
- function GetUpdateRgn. If UpdateRgn = 0, this means that entire
- window should be repainted. Otherwise, You (e.g.) can check
- if the rectangle is in clipping region using API function
- RectInRegion. }
-
- property EraseBackground: Boolean read fEraseUpdRgn write fEraseUpdRgn;
- {* This value is used to pass it to the API function GetUpdateRgn,
- when UpadateRgn property is obtained first in responce to WM_PAINT
- message. If EraseBackground is set to True, system is responsible
- for erasing background of update region before painting. If not
- (default), the entire region invalidated should be painted by your
- event handler. }
- {$ENDIF GDI}
- property OnPaint: TOnPaint read fOnPaint write SetOnPaint;
- {* Event to set to override standard control painting. Can be applied
- to any control (though originally was designed only for paintbox
- control). When an event handler is called, it is possible to use
- UpdateRgn to examine what parts of window require painting to
- improve performance of the painting operation. }
- {$IFDEF GDI}
- property OnPrePaint: TOnPaint read fOnPrePaint write fOnPrePaint;
- {* Only for graphic controls. If you assign it, call Invalidate also. }
- property OnPostPaint: TOnPaint read fOnPostPaint write fOnPostPaint;
- {* Only for graphic controls. If you assign it, call Invalidate also. }
-
- property OnEraseBkgnd: TOnPaint read fOnEraseBkgnd write SetOnEraseBkgnd;
- {* This event allows to override erasing window background in response
- to WM_ERASEBKGND message. This allows to add some decorations to
- standard controls without overriding its painting in total.
- Note: When erase background, remember, that property ClientRect can
- return not true client rectangle of the window - use GetClientRect
- API function instead. For example:
- !
- !var BkBmp: HBitmap;
- !
- !procedure TForm1.KOLForm1FormCreate(Sender: PObj);
- !begin
- ! Toolbar1.OnEraseBkgnd := DecorateToolbar;
- ! BkBmp := LoadBitmap( hInstance, 'BK1' );
- !end;
- !
- !procedure TForm1.DecorateToolbar(Sender: PControl; DC: HDC);
- !var CR: TRect;
- !begin
- ! GetClientRect( Sender.Handle, CR );
- ! Sender.Canvas.Brush.BrushBitmap := BkBmp;
- ! Sender.Canvas.FillRect( CR );
- !end;
- !
- }
-
- {$ENDIF GDI}
- property OnClick: TOnEvent read fOnClick write
- {$IFDEF GDI} fOnClick
- {$ELSE _X_} SetOnClick {$ENDIF _X_};
- {* |<#button>
- |<#checkbox>
- |<#radiobox>
- |<#toolbar>
- Called on click at control. For buttons, checkboxes and radioboxes
- is called regadless if control clicked by mouse or keyboard. For toolbar,
- the same event is used for all toolbar buttons and toolbar itself.
- To determine which toolbar button is clicked, check CurIndex property.
- And note, that all the buttons including separator buttons are enumerated
- starting from 0. Though images are stored (and prepared) only for
- non-separator buttons. And to determine, if toolbar button was clicked
- with right mouse button, check RightClick property.
- |<br>
- This event does not work on a Form, still it is fired in responce to
- WM_COMMAND window message mainly rather direct to mouse down. But, if
- you want to have OnClick event to be fired on a Form, use (following)
- property OnFormClick to assign it. }
- {$IFDEF GDI}
- property OnFormClick: TOnEvent read fOnClick write SetFormOnClick;
- {* |<#form>
- Assign you OnClick event handler using this property, if you want it to
- be fired in result of mouse click on a form surface. Use to assign the
- event only for forms (to avoid doublicated firing the handler).
- |<br>
- Note: for a form, in case of WM_xDOUBLECLK event, this event is fired
- for both clicks. So if you install both OnFormClick and OnMouseDblClk,
- handlers will be called in the following sequence for each double click:
- OnFormClick; OnMouseDblClk; OnFormClick. }
- property RightClick: Boolean read fRightClick;
- {* |<#toolbar>
- |<#listview>
- Use this property to determine which mouse button was clicked
- (applicable to toolbar in the OnClick event handler). }
- property OnEnter: TOnEvent read fOnEnter write fOnEnter;
- {* Called when control receives focus. }
- property OnLeave: TOnEvent read fOnLeave write fOnLeave;
- {* Called when control looses focus. }
- property OnChange: TOnEvent read fOnChange write fOnChange;
- {* |<#edit>
- |<#memo>
- |<#listbox>
- |<#combo>
- |<#tabcontrol>
- Called when edit control is changed, or selection in listbox or
- current index in combobox is changed (but if OnSelChanged assigned,
- the last is called for change selection). To respond to check/uncheck
- checkbox or radiobox events, use OnClick instead. }
- property OnSelChange: TOnEvent read fOnSelChange write fOnSelChange;
- {* |<#richedit>
- |<#listbox>
- |<#combo>
- |<#treeview>
- Called for rich edit control, listbox, combobox or treeview when current selection
- (range, or current item) is changed. If not assigned, but OnChange is
- assigned, OnChange is called instead. }
- property OnResize: TOnEvent read FOnResize write SetOnResize;
- {* Called whenever control receives message WM_SIZE (thus is, if
- control is resized. }
- property OnMove: TOnEvent read FOnMove write SetOnMove;
- {* Called whenever control receives message WM_MOVE (i.e. when control is
- moved over its parent). }
- property OnMoving: TOnEventMoving read FOnMoving write SetOnMoving;
- {* Called whenever control receives message WM_MOVE (i.e. when control is
- moved over its parent). }
-
- property MinSizePrev: Integer read fSplitMinSize1 write fSplitMinSize1;
- {* |<#splitter>
- Minimal allowed (while dragging splitter) size of previous control
- for splitter (see NewSplitter). }
- property SplitMinSize1: Integer read fSplitMinSize1 write fSplitMinSize1;
- {* The same as MinSizePrev. }
- property MinSizeNext: Integer read fSplitMinSize2 write fSplitMinSize2;
- {* |<#splitter>
- Minimal allowed (while dragging splitter) size of the rest of parent
- of splitter or of SecondControl (see NewSplitter). }
- property SplitMinSize2: Integer read fSplitMinSize2 write fSplitMinSize2;
- {* The same as MinSizeNext. }
- property SecondControl: PControl read fSecondControl write fSecondControl;
- {* |<#splitter>
- Second control to check (while dragging splitter) if its size not less
- than SplitMinSize2 (see NewSplitter). By default, second control is
- not necessary, and needed only in rare case when SecondControl can not
- be determined automatically to restrict splitter right (bottom) position. }
- property OnSplit: TOnSplit read fOnSplit write fOnSplit;
- {* |<#splitter>
- Called when splitter control is dragging - to allow for
- your event handler to decide if to accept new size of
- left (top) control, and new size of the rest area of parent. }
- property Dragging: Boolean read FDragging;
- {* |<#splitter>
- True, if splitter control is dragging now by user with left
- mouse button. Also, this property can be used to detect if the control
- is dragging with mouse (after calling DragStartEx method). }
- procedure DragStart;
- {* Call this method for a form or control to drag it with left mouse button,
- when mouse left button is already down. Dragging is stopped when left mouse
- button is released. See also DragStartEx, DragStopEx. }
- procedure DragStartEx;
- {* Call this method to start dragging the form by mouse. To stop
- dragging, call DragStopEx method. (Tip: to detect mouse up event,
- use OnMouseUp event of the dragging control). This method can be used
- to move any control with the mouse, not only entire form. State of
- mouse button is not significant. Determine dragging state of the control
- checking its Dragging property. }
- procedure DragStopEx;
- {* Call this method to stop dragging the form (started by DragStopEx). }
- procedure DragItem( OnDrag: TOnDrag );
- {* Starts dragging something with mouse. During the process,
- callback function OnDrag is called, which allows to control
- drop target, change cursor shape, etc. }
-
- property OnKeyDown: TOnKey read fOnKeyDown write SetOnKeyDown;
- {* Obvious. }
- property OnKeyUp: TOnKey read fOnKeyUp write SetOnKeyUp;
- {* Obvious. }
- property OnChar: TOnChar read fOnChar write SetOnChar;
- {* Deprecated event, use OnKeyChar. }
- property OnKeyChar: TOnChar read fOnChar write SetOnChar;
- {* Obviuos. }
- {$IFDEF SUPPORT_ONDEADCHAR}
- property OnKeyDeadChar: TOnChar read fOnDeadChar write SetOnDeadChar;
- {* Obviuos. }
- {$ENDIF SUPPORT_ONDEADCHAR}
-
- {$ENDIF GDI}
- property OnMouseUp: TOnMouse read fOnMouseUp write SetOnMouseUp;
- {* Obvious. }
- property OnMouseDown: TOnMouse read fOnMouseDown write SetOnMouseDown;
- {* Obvious. }
- property OnMouseMove: TOnMouse read fOnMouseMove write SetOnMouseMove;
- {* Obvious. }
- property OnMouseDblClk: TOnMouse read fOnMouseDblClk write SetOnMouseDblClk;
- {* Obvious. }
- property ThreeButtonPress: Boolean read f3ButtonPress;
- {* TRUE, if 3 button press detected. Check this flag in OnMouseDblClk event
- handler. If 3rd button click is done for a short period of time after the
- double click, the control receives OnMouseDblClk the second time and this
- flag is set. (Applicable to the GDK and other Linux systems). }
- property OnMouseWheel: TOnMouse read fOnMouseWheel write SetOnMouseWheel;
- {* Mouse wheel (up or down) event. In Windows, only focused controls and
- controls having scrollbars (or a scrollbar iteself) receive such
- message. To get direction and amount of wheel, use typecast:
- SmallInt( HiWord( Mouse.Shift ) ). Value 120 corresponds to one wheel
- step (-120 - for step back). }
- {$IFDEF GDI}
-
- property OnMouseEnter: TOnEvent read fOnMouseEnter write SetOnMouseEnter;
- {* Is called when mouse is entered into control. See also OnMouseLeave. }
- property OnMouseLeave: TOnEvent read fOnMouseLeave write SetOnMouseLeave;
- {* Is called when mouse is leaved control. If this event is assigned,
- then mouse is captured on mouse enter event to handle all other
- mouse events until mouse cursor leaves the control. }
- property OnTestMouseOver: TOnTestMouseOver read fOnTestMouseOver write SetOnTestMouseOver;
- {* |<#bitbtn>
- Special event, which allows to extend OnMouseEnter / OnMouseLeave
- (and also Flat property for BitBtn control). If a handler is assigned
- to this event, actual testing whether mouse is in control or not,
- is occuring in the handler. So, it is possible to simulate more
- careful hot tracking for controls with non-rectangular shape (such
- as glyphed BitBtn control). }
-
- property MouseInControl: Boolean read fMouseInControl;
- {* |<#bitbtn>
- This property can return True only if OnMouseEnter / OnMouseLeave
- event handlers are set for a control (or, for BitBtn, property Flat
- is set to True. Otherwise, False is returned always. }
-
- property Flat: Boolean read fFlat write SetFlat;
- {* |<#bitbtn>
- Set it to True for BitBtn, to provide either flat border for a button
- or availability of "highlighting" (correspondent to glyph index 4).
- |<br>
- Note: this can work incorrectly a bit under win95 without comctl32.dll
- updated. Therefore, application will launch. To enforce correct working
- even under Win95, use your own timer, which event handler checks for
- mouse over bitbtn control, e.g.:
- ! procedure TForm1.Timer1Timer(Sender: PObj);
- ! var P: TPoint;
- ! begin
- ! if not BitBtn1.MouseInControl then Exit;
- ! GetCursorPos( P );
- ! P := BitBtn1.Screen2Client( P );
- ! if not PtInRect( BitBtn1.ClientRect, P ) then
- ! begin
- ! BitBtn1.Flat := FALSE;
- ! BitBtn1.Flat := TRUE;
- ! end;
- ! end;
- }
- property RepeatInterval: Integer read fRepeatInterval write fRepeatInterval;
- {* |<#bitbtn>
- If this property is set to non-zero, it is interpreted (for BitBtn
- only) as an interval in milliseconds between repeat button down events,
- which are generated after first mouse or button click and until
- button is released. Though, if the button is pressed with keyboard (with
- space key), RepeatInterval value is ignored and frequency of repeatitive
- clicking is determined by user keyboard settings only. }
- function LikeSpeedButton: PControl;
- {* |<#button>
- |<#bitbtn>
- Transparent method (returns control itself). Makes button not focusable. }
-
- function Add( const S: KOLString ): Integer;
- {* |<#listbox>
- |<#combo>
- Only for listbox and combobox. }
-
- function Insert( Idx: Integer; const S: KOLString ): Integer;
- {* |<#listbox>
- |<#combo>
- Only for listbox and combobox. }
- procedure Delete( Idx: Integer );
- {* |<#listbox>
- |<#combo>
- Only for listbox and combobox. }
- procedure Clear;
- {* Clears object content. Has different sense for different controls.
- E.g., for label, editbox, button and other simple controls it
- assigns empty string to Caption property. For listbox, combobox,
- listview it deletes all items. For toolbar, it deletes all buttons.
- Et so on. }
-
- property Progress: Integer index ((PBM_SETPOS or $8000) shl 16) or PBM_GETPOS
- read GetIntVal write SetIntVal;
- {* |<#progressbar>
- Only for ProgressBar. }
- property MaxProgress: Integer index ((PBM_SETRANGE32 or $8000) shl 16) or PBM_GETRANGE
- read GetIntVal write SetMaxProgress;
- {* |<#progressbar>
- Only for ProgressBar. 100 is the default value. }
- property ProgressColor: TColor read fTextColor write SetProgressColor;
- {* |<#progressbar>
- Only for ProgressBar. }
- property ProgressBkColor: TColor read fColor write SetCtlColor; //SetProgressBkColor;
- {* |<#progressbar>
- Obsolete. Now the same as Color. }
-
- property StatusText[ Idx: Integer ]: PKOLChar read GetStatusText write SetStatusText;
- {* |<#form>
- Only for forms to set/retrieve status text to/from given status panel.
- Panels are enumerated from 0 to 254, 255 is to indicate simple
- status bar. Size grip in right bottom corner of status window is
- displayed only if form still CanResize.
- |<br>
- When a status text is set first time, status bar window is created
- (always aligned to bottom), and form is resizing to preset client height.
- While status bar is showing, client height value is returned without
- height of status bar. To remove status bar, call RemoveStatus method for
- a form.
- |<br>
- By default, text is left-aligned within the specified part of a status
- window. You can embed tab characters (#9) in the text to center or
- right-align it. Text to the right of a single tab character is centered,
- and text to the right of a second tab character is right-aligned.
- |<br>
- If You use separate status bar onto several panels, these automatically
- align its widths to the same value (width divided to number of panels).
- To adjust status panel widths for every panel, use property StatusPanelRightX.
- }
- property SimpleStatusText: PKOLChar index 255 read GetStatusText write SetStatusText;
- {* |<#form>
- Only for forms to set/retrive status text to/from simple status bar.
- Size grip in right bottom corner of status window is displayed only
- if form CanResize.
- |<br>
- When status text set first time, (simple) status bar window is created
- (always aligned to bottom), and form is resizing to preset client height.
- While status bar is showing, client height value is returned without
- height of status bar. To remove status bar, call RemoveStatus method for
- a form.
- |<br>
- By default, text is left-aligned within the specified part of a status
- window. You can embed tab characters (#9) in the text to center or
- right-align it. Text to the right of a single tab character is centered,
- and text to the right of a second tab character is right-aligned.
- }
- property StatusCtl: PControl read fStatusCtl;
- {* Pointer to Status bar control. To "create" child controls on
- the status bar, first create it as a child of form, for instance, and
- then change its property Parent, e.g.:
- ! var Progress1: PControl;
- ! ...
- ! Progress1 := NewProgressBar( Form1 );
- ! Progress1.Parent := Form1.StatusCtl;
- (If you use MCK, code should be another a bit, and in this case it is
- possible to create and adjust the control at design-time, and at run-time
- change its parent control. E.g. (Progress1 is created at run-time here too):
- ! Progress1 := NewProgressBar( Form );
- ! Progress1.Parent := Form.StatusCtl;
- ).
- Do not forget to provide StatusCtl to be existing first (e.g. assign
- one-space string to SimpleStatusText property of the form, for MCK do
- so using Object Inspector).
- }
- property SizeGrip: Boolean read fSizeGrip write fSizeGrip;
- {* Size grip for status bar. Has effect only before creating window. }
-
- procedure RemoveStatus;
- {* |<#form>
- Call it to remove status bar from a form (created in result of assigning
- value(s) to StatusText[], SimpleStatusText properties). When status bar is
- removed, form is resized to preset client height. }
- function StatusPanelCount: Integer;
- {* |<#form>
- Returns number of status panels defined in status bar. }
- property StatusPanelRightX[ Idx: Integer ]: Integer read GetStatusPanelX write SetStatusPanelX;
- {* |<#form>
- Use this property to adjust status panel right edges (if the status bar is
- divided onto several subpanels). If the right edge for the last panel is
- set to -1 (by default) it is expanded to the right edge of a form window.
- Otherwise, status bar can be shorter then form width. }
- property StatusWindow: HWND read fStatusWnd;
- {* |<#form>
- Provided for case if You want to use API direct message sending to
- status bar. }
-
- property Color1: TColor read fColor1 write SetColor1;
- {* |<#gradient>
- Top line color for GradientPanel. }
- property Color2: TColor read fColor2 write SetColor2;
- {* |<#gradient>
- |<#3Dlabel>
- Bottom line color for GradientPanel, or shadow color for LabelEffect.
- (If clNone, shadow color for LabelEffect is calculated as a mix bitween
- TextColor and clBlack). }
- property GradientStyle: TGradientStyle read FGradientStyle write SetGradientStyle;
- {* |<#gradient>
- Styles other then gsVertical and gsHorizontal has effect only for
- gradient panel, created by NewGradientPanelEx. }
- property GradientLayout: TGradientLayout read FGradientLayout write SetGradientLayout;
- {* |<#gradient>
- Has only effect for gradient panel, created by NewGradientPanelEx.
- Ignored for styles gsVertical and gsHorizontal. }
-
- //======== Image lists (for ListView, TreeView, ToolBar and TabControl):
- property ImageListSmall: PImageList index 16 read GetImgListIdx write SetImgListIdx;
- {* |<#listview>
- Image list with small icons used with List View control. If not set,
- last added (i.e. created with a control as an owner) image list with
- small icons is used. }
- property ImageListNormal: PImageList index 32 read GetImgListIdx write SetImgListIdx;
- {* |<#listview>
- |<#treeview>
- |<#tabcontrol>
- |<#bitbtn>
- Image list with normal size icons used with List View control (or with
- icons for BitBtn, TreeView or TabControl). If not set,
- last added (i.e. created with a control as an owner) image list is used.
- }
- property ImageListState: PImageList index 0 read GetImgListIdx write SetImgListIdx;
- {* |<#listview>
- |<#treeview>
- Image list used as a state images list for ListView or TreeView control. }
-
- //========
- function SetUnicode( Unicode: Boolean ): PControl;
- {* |<#listview>
- |<#treeview>
- |<#tabcontrol>
- Sets control as Unicode or not. The control itself is returned as for
- other "transparent" functions. A conditional define UNICODE_CTRLS must
- be added to a project to provide handling unicode messages. }
-
- //======== TabControl-specific properties and methods:
- property Pages[ Idx: Integer ]: PControl read GetPages;
- {* |<#tabcontrol>
- Returns controls, which can be used as parent for controls, placed on
- different pages of a tab control. Use it like in follows example:
- | Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
- To find number of pages available, check out Count property of the tab
- control. Pages are enumerated from 0 to Count - 1, as usual. }
- property TC_Pages[ Idx: Integer ]: PControl read GetPages;
- {* |<#tabcontrol>
- The same as above. }
- function TC_Insert( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer ): PControl;
- {* |<#tabcontrol>
- Inserts new tab before given, returns correspondent page control
- (which can be used as a parent for controls to place on the page). }
- procedure TC_Delete( Idx: Integer );
- {* |<#tabcontrol>
- Removes tab from tab control, destroying all its child controls. }
- {$IFNDEF OLD_ALIGN}
- procedure TC_InsertControl( Idx: Integer; const TabText: KOLString; TabImgIdx: Integer; Page: PControl);
- {* |<#tabcontrol>
- Inserts new tab before given, but not construt this Page
- (this control must be created before inserting, and may be not a Panel). }
- function TC_Remove( Idx: Integer ):PControl;
- {* |<#tabcontrol>
- Only removes tab from tab control, and return this Page as Result. }
- {$ENDIF}
- property TC_Items[ Idx: Integer ]: KOLString read TCGetItemText write TCSetItemText;
- {* |<#tabcontrol>
- Text, displayed on tab control tabs. }
- property TC_Images[ Idx: Integer ]: Integer read TCGetItemImgIDx write TCSetItemImgIdx;
- {* |<#tabcontrol>
- Image index for a tab in tab control. }
- property TC_ItemRect[ Idx: Integer ]: TRect read TCGetItemRect;
- {* |<#tabcontrol>
- Item rectangle for a tab in tab control. }
- procedure TC_SetPadding( cx, cy: Integer );
- {* |<#tabcontrol>
- Sets space padding around tab text in a tab of tab control. }
- function TC_TabAtPos( x, y: Integer ): Integer;
- {* |<#tabcontrol>
- Returns index of tab, found at the given position (relative to
- a client rectangle of tab control). If no tabs found at the
- position, -1 is returned. }
- function TC_DisplayRect: TRect;
- {* |<#tabcontrol>
- Returns rectangle, occupied by a page rather then tab. }
- function TC_IndexOf(const S: KOLString): Integer;
- {* |<#tabcontrol>
- By Mr Brdo. Index of page by its Caption. }
- function TC_SearchFor(const S: KOLString; StartAfter: Integer; Partial: Boolean): Integer;
- {* |<#tabcontrol>
- By Mr Brdo. Index of page by its Caption. }
-
- //======== ListView style and options:
- property LVStyle: TListViewStyle read fLVStyle write SetLVStyle;
- {* |<#listview>
- ListView style of view. Can be changed at run time. }
-
- property LVOptions: TListViewOptions read fLVOptions write SetLVOptions;
- {* |<#listview>
- ListView options. Can be changed at run time. }
-
- property LVTextColor: TColor index LVM_GETTEXTCOLOR
- {$IFDEF F_P} read LVGetColorByIdx
- {$ELSE DELPHI} read fTextColor
- {$ENDIF F_P/DELPHI} write LVSetColorByIdx;
- {* |<#listview>
- ListView text color. Use it instead of Font.Color. }
- property LVTextBkColor: TColor index LVM_GETTEXTBKCOLOR
- {$IFDEF F_P} read LVGetColorByIdx
- {$ELSE DELPHI} read fLVTextBkColor
- {$ENDIF F_P/DELPHI} write LVSetColorByIdx;
- {* |<#listview>
- ListView background color for text. }
- property LVBkColor: TColor read fColor write SetCtlColor; //LVSetBkColor;
- {* |<#listview>
- ListView background color. Use it instead of Color. }
-
- //======== List View columns handling:
- property LVColCount: Integer read fLVColCount;
- {* |<#listview>
- ListView (additional) column count. Value 0 means that there are
- no columns (single item text / icon is used). If You want
- to provide several columns, first call LVColAdd to "insert" column 0,
- i.e. to provide header text for first column (with index 0).
- If there are no column, nothing will be shown in lvsDetail /
- lvsDetailNoHeader view style. }
- procedure LVColAdd( const aText: KOLString; aalign: TTextAlign; aWidth: Integer );
- {* |<#listview>
- Adds new column. Pass 'width' <= 0 to provide default column width.
- 'text' is a column header text. }
- procedure LVColInsert( ColIdx: Integer; const aText: KOLString; aAlign: TTextAlign; aWidth: Integer );
- {* |<#listview>
- Inserts new column at the Idx position (1-based column index). }
- procedure LVColDelete( ColIdx: Integer );
- {* |<#listview>
- Deletes column from List View }
- property LVColWidth[ Item: Integer ]: Integer index LVM_GETCOLUMNWIDTH
- read GetItemVal write SetItemVal;
- {* |<#listview>
- Retrieves or changes column width. For lvsList view style, the same width
- is returned for all columns (ColIdx is ignored). It is possible to use
- special values to assign to a property:
- |<br> LVSCW_AUTOSIZE - Automatically sizes the column
- |<br> LVSCW_AUTOSIZE_USEHEADER - Automatically sizes the column to fit
- the header text
- |<br>
- To set coumn width in lvsList view mode, column index must be -1
- (and Width to set must be in range 0..32767 always). }
- property LVColText[ Idx: Integer ]: KOLString read GetLVColText write SetLVColText;
- {* |<#listview>
- Allows to get/change column header text at run time. }
- property LVColAlign[ Idx: Integer ]: TTextAlign read GetLVColalign write SetLVColalign;
- {* |<#listview>
- Column text aligning. }
- property LVColImage[ Idx: Integer ]: Integer index LVCF_IMAGE or (24 shl 16) read GetLVColEx write SetLVColEx;
- {* |<#listview>
- Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
- set an image for list view column itself from the ImageListSmall.
- }
- property LVColOrder[ Idx: Integer ]: Integer index LVCF_ORDER or (28 shl 16) read GetLVColEx write SetLVColEx;
- {* |<#listview>
- Only starting from comctrl32.dll of version 4.70 (IE4+). Allows to
- set visual order of the list view column from the ImageListSmall.
- This value does not affect the index, by which the column is still
- accessible in the column array.
- }
-
- //======== List View items handling:
- property LVCount: Integer read GetItemsCount write SetItemsCount;
- {* |<#listview>
- Returns item count for ListView control. It is possible to use Count
- property instead when obtaining of item count is needed only. But this this
- property allows also to set actual count of list view items when a list
- view is virtual. }
-
- property LVCurItem: Integer read GetLVCurItem write SetLVCurItem;
- {* |<#listview>
- Returns first selected item index in a list view. See also LVNextSelected,
- LVNextItem and LVFocusItem functions. }
-
- property LVFocusItem: Integer read GetLVFocusItem;
- {* |<#listview>
- Returns focused item index in a list view. See also LVCurItem. }
-
- function LVNextItem( IdxPrev: Integer; Attrs: DWORD ): Integer;
- {* |<#listview>
- Returns an index of the next after IdxPrev item with given attributes in
- the list view. Attributes can be:
- LVNI_ALL - Searches for a subsequent item by index, the default value.
- |<br><br>
- Searchs by physical relationship to the index of the item where the
- search is to begin.
- LVNI_ABOVE - Searches for an item that is above the specified item.
- LVNI_BELOW - Searches for an item that is below the specified item.
- LVNI_TOLEFT - Searches for an item to the left of the specified item.
- LVNI_TORIGHT - Searches for an item to the right of the specified item.
- |<br><br>
- The state of the item to find can be specified with one or a combination
- of the following values:
- LVNI_CUT - The item has the LVIS_CUT state flag set.
- LVNI_DROPHILITED - The item has the LVIS_DROPHILITED state flag set
- LVNI_FOCUSED - The item has the LVIS_FOCUSED state flag set.
- LVNI_SELECTED - The item has the LVIS_SELECTED state flag set.}
- function LVNextSelected( IdxPrev: Integer ): Integer;
- {* |<#listview>
- Returns an index of next (after IdxPrev) selected item in a list view. }
-
- function LVAdd( const aText: KOLString; ImgIdx: Integer; State: TListViewItemState;
- StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
- {* |<#listview>
- Adds new line to the end of ListView control. Only content of item itself
- is set (aText, ImgIdx). To change other column text and attributes of
- item added, use appropriate properties / methods ().
- |<br>
- Returns an index of added item.
- |<br>
- There is no Unicode version defined, use LVItemAddW instead. }
- function LVItemAdd( const aText: KOLString ): Integer;
- {* |<#listview>
- Adds an item to the end of list view. Returns an index of the item added. }
- function LVInsert( Idx: Integer; const aText: KOLString; ImgIdx: Integer;
- State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD ): Integer;
- {* |<#listview>
- Inserts new line before line with index Idx in ListView control. Only
- content of item itself is set (aText, ImgIdx). To change other column
- text and attributes of item added, use appropriate properties / methods ().
- if ImgIdx = I_IMAGECALLBACK, event handler OnGetLVItemImgIdx is responsible
- for returning image index for an item ( /// not implemented yet /// )
- Pass StateImgIdx and OverlayImgIdx = 0 (ignored in that case) or 1..15 to
- use correspondent icon from ImageListState image list.
- |<br> Returns an index of item inserted.
- |<br> There is no unicode version of this method, use LVItemInsertW. }
- function LVItemInsert( Idx: Integer; const aText: KOLString ): Integer;
- {* |<#listview>
- Inserts an item to Idx position. }
-
- procedure LVDelete( Idx: Integer );
- {* |<#listview>
- Deletes item of ListView with subitems (full row - in lvsDetail view style. }
- procedure LVSetItem( Idx, Col: Integer; const aText: KOLString; ImgIdx: Integer;
- State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer; Data: DWORD );
- {* |<#listview>
- Use this method to set item data and item columns data for ListView control.
- It is possible to pass I_SKIP as ImgIdx, StateImgIdx, OverlayImgIdx values to
- skip setting this fields. But all other are set always. Like in LVInsert /
- LVAdd, ImgIdx can be I_IMAGECALLBACK to determine that image will be
- retrieved in OnGetItemImgIdx event handler when needed.
- |<br>
- If this method is called to set data for column > 0, parameters ImgIdx and
- Data are ignored anyway.
- |<br> There is no unicode version of this method, use other methods
- to set up listed properties separately using correspondent W-functions. }
-
- property LVItemState[ Idx: Integer ]: TListViewItemState read LVGetItemState write LVSetItemState;
- {* |<#listview>
- Access to list view item states set [lvisBlend, lvisHighlight, lvisFocus,
- lvisSelect]. When assign new value to the property, it is possible to use
- special index value -1 to change state for all items for a list view
- (but only when lvoMultiselect style is applied to the list view, otherwise
- index -1 is referring to the last item of the list view). }
-
- property LVItemIndent[ Idx: Integer ]: Integer read LVGetItemIndent write LVSetItemIndent;
- {* Item indentation. Indentation is calculated as this value multiplied to
- image list ImgWidth value (Image list must be applied to list view).
- Note: indentation supported only if IE3.0 or higher installed. }
- property LVItemStateImgIdx[ Idx: Integer ]: Integer read LVGetSttImgIdx write LVSetSttImgIdx;
- {* |<#listview>
- Access to state image of the item. Use index -1 to assign the same state
- image index to all items of the list view at once (fast).
- Option lvoCheckBoxes just means, that control itself creates special inner
- image list for two state images. Later it is possible to examine checked
- state for items or set checked state programmatically by changing
- LVItemStateImgIdx[ ] property. Value 1 corresponds to unchecked state,
- 2 to checked. Value 0 allows to remove checkbox at all. So, to check all
- added items by default (e.g.), do following:
- ! ListView1.LVItemStateImgIdx[ -1 ] := 2;
- |<br>Use 1-based index of the image
- in image list ImageListState. Value 0 reserved to use as "no state image".
- Values 1..15 can be used only - this is the Windows restriction on
- state images. }
- property LVItemOverlayImgIdx[ Idx: Integer ]: Integer read LVGetOvlImgIdx write LVSetOvlImgIdx;
- {* |<#listview>
- Access to overlay image of the item. Use index -1 to assign the same
- overlay image to all items of the list view at once (fast). }
- property LVItemData[ Idx: Integer ]: DWORD read LVGetItemData write LVSetItemData;
- {* |<#listview>
- Access to user defined data, assiciated with the item of the list view. }
- procedure LVSelectAll;
- {* |<#listview>
- Call this method to select all the items of the list view control. }
- property LVSelCount: Integer read GetSelLength; // write SetSelLength;
- {* |<#listview>
- Returns number of items selected in listview. }
- property LVItemImageIndex[ Idx: Integer ]: Integer read LVGetItemImgIdx write LVSetItemImgIdx;
- {* |<#listview>
- Image index of items in listview. When an item is created (using LVItemAdd
- or LVItemInsert), image index 0 is set by default (not -1 like in VCL!). }
- property LVItems[ Idx, Col: Integer ]: KOLString read LVGetItemText write LVSetItemText;
- {* |<#listview>
- Access to List View item text. }
- function LVItemRect( Idx: Integer; Part: TGetLVItemPart ): TRect;
- {* |<#listview>
- Returns rectangle occupied by given item part(s) in ListView window.
- Empty rectangle is returned, if the item is not viewing currently. }
- function LVSubItemRect( Idx, ColIdx: Integer ): TRect;
- {* |<#listview>
- Returns rectangle occupied by given item's subitem in ListView window,
- in lvsDetail or lvsDetailNoHeader style. Empty rectangle (0,0,0,0) is
- returned if the item is not viewing currently. Left or/and right bounds
- of the rectangle returned can be outbound item rectangle if only a part
- of the subitem is visible or the subitem is not visible in the item,
- which is visible itself. }
- property LVItemPos[ Idx: Integer ]: TPoint read LVGetItemPos write LVSetItemPos;
- {* |<#listview>
- Position of List View item (can be changed in icon or small icon view). }
- function LVItemAtPos( X, Y: Integer ): Integer;
- {* |<#listview>
- Return index of item at the given position. }
- function LVItemAtPosEx( X, Y: Integer; var Where: TWherePosLVItem ): Integer;
- {* |<#listview>
- Retrieves index of item and sets in Where, what part of item is under
- given coordinates. If there are no items at the specified position,
- -1 is returned. }
- procedure LVMakeVisible( Item: Integer; PartiallyOK: Boolean );
- {* |<#listview>
- Makes listview item visible. Ignred when Item passed < 0. }
- procedure LVEditItemLabel( Idx: Integer );
- {* |<#listview>
- Begins in-place editing of item label (first column text). }
- procedure LVSort;
- {* |<#listview>
- Initiates sorting of list view items. This sorting procedure is available only
- for Win2K, WinNT4 with IE5, Win98 or Win95 with IE5. See also LVSortData. }
- procedure LVSortData;
- {* |<#listview>
- Initiates sorting of list view items. This sorting procedure is always available
- in Windows95/98, NT/2000. But OnCompareLVItems procedure receives not indexes of
- items compared but its Data field associated instead. }
- procedure LVSortColumn( Idx: Integer );
- {* |<#listview>
- This is a method to simplify sort by column. Just call it in your OnColumnClick
- event passing column index and enjoy with your list view sorted automatically
- when column header is clicked. Requieres Windows2000 or Winows98, not supported
- under WinNT 4.0 and below and under Windows95.
- |<br>
- Either lvoSortAscending or lvoSortDescending option must be set in
- LVOptions, otherwise no sorting is performed. }
- function LVIndexOf( const S: KOLString ): Integer;
- {* Returns first list view item index with caption matching S.
- The same as LVSearchFor( S, -1, FALSE ). }
- function LVSearchFor( const S: KOLString; StartAfter: Integer; Partial: Boolean ): Integer;
- {* Searches an item with Caption equal to S (or starting from S, if Partial = TRUE).
- Searching is started after an item specified by StartAfter parameter. }
-
- //======== List view page:
- property LVTopItem: Integer index LVM_GETTOPINDEX read GetIntVal; //LVGetTopItem;
- {* |<#listview>
- Returns index of topmost visible item of ListView in lvsList view style. }
- property LVPerPage: Integer index LVM_GETCOUNTPERPAGE read GetIntVal; //LVGetPerPage;
- {* |<#listview>
- Returns the number of fully-visible items if successful. If the current
- view is icon or small icon view, the return value is the total number
- of items in the list view control. }
-
- //======== List View specific events:
- property OnEndEditLVItem: TOnEditLVItem read fOnEndEditLVITem write SetOnEndEditLVItem;
- {* |<#listview>
- Called when edit of an item label in ListView control finished. Return
- True to accept new label text, or false - to not accept it (item label
- will not be changed). If handler not set to an event, all changes are
- accepted. }
-
- property OnLVDelete: TOnDeleteLVItem read fOnDeleteLVItem write SetOnDeleteLVItem;
- {* |<#listview>
- This event is called when an item is deleted in the listview.
- Do not add, delete, or rearrange items in the list view while processing
- this notification. }
- property OnDeleteLVItem: TOnDeleteLVItem read fOnDeleteLVItem write SetOnDeleteLVItem;
- {* |<#listview>
- Called for every deleted list view item. }
- property OnDeleteAllLVItems: TOnEvent read fOnDeleteAllLVItems write SetOnDeleteAllLVItems;
- {* |<#listview>
- Called when all the items of the list view control are to be deleted. If after
- returning from this event handler event OnDeleteLVItem is yet assigned,
- an event OnDeleteLVItem will be called for every deleted item. }
- property OnLVData: TOnLVData read fOnLVData write SetOnLVData;
- {* |<#listview>
- Called to provide virtual list view with actual data. To use list view as
- virtaul list view, define also lvsOwnerData style and set Count property
- to actual row count of the list view. This manner of working with list view
- control can greatly improve performance of an application when working with
- huge data sets represented in listview control. }
-
- property OnCompareLVItems: TOnCompareLVItems read fOnCompareLVItems write fOnCompareLVItems;
- {* |<#listview>
- Event to compare two list view items during sort operation (initiated by
- LVSort method call). Do not send any messages to the list view control
- while it is sorting - results can be unpredictable! }
- property OnColumnClick: TOnLVColumnClick read fOnColumnClick write SetOnColumnClick;
- {* |<#listview>
- This event handler is called when column of the list view control is clicked.
- You can use this event to initiate sorting of list view items by this column. }
- property OnLVStateChange: TOnLVStateChange read FOnLVStateChange write SetOnLVStateChange;
- {* |<#listview>
- This event occure when an item or items range in list view control are
- changing its state (e.g. selected or unselected). }
- property OnDrawItem: TOnDrawItem read fOnDrawItem write SetOnDrawItem;
- {* |<#listview>
- |<#listbox>
- |<#combo>
- This event can be used to implement custom drawing for list view, list box, dropped
- list of a combobox. For a list view, custom drawing using this event is possible
- only in lvsDetail and lvsDetailNoHeader styles, and OnDrawItem is called to draw
- entire row at once only. See also OnLVCustomDraw event. }
-
- property OnLVCustomDraw: TOnLVCustomDraw read FOnLVCustomDraw write SetOnLVCustomDraw;
- {* |<#listview>
- Custom draw event for listview. For every item to be drawn, this event
- can be called several times during a single drawing cycle - depending on
- a result, returned by an event handler. Stage can have one of following
- values:
- |<pre>
- CDDS_PREERASE
- CDDS_POSTERASE
- CDDS_ITEMPREERASE
- CDDS_PREPAINT
- CDDS_ITEMPREPAINT
- CDDS_ITEM
- CDDS_SUBITEM + CDDS_ITEMPREPAINT
- CDDS_SUBITEM + CDDS_ITEMPOSTPAINT
- CDDS_ITEMPOSTPAINT
- CDDS_POSTPAINT
- </pre>
- When called, see on Stage to get know, on what stage the event is
- activated. And depend on the stage and on what you want to paint,
- return a value as a result, which instructs the system, if to use
- default drawing on this (and follows) stage(s) for the item, and if
- to notify further about different stages of drawing the item during
- this drawing cycle. Possible values to return are:
- |<pre>
- CDRF_DODEFAULT - perform default drawing. Do not notify further for this
- item (subitem) (or for entire listview, if called with
- flag CDDS_ITEM reset - ?);
- CDRF_NOTIFYITEMDRAW - return this value, when the event is called the
- first time in a cycle of drawing, with ItemIdx = -1 and
- flag CDDS_ITEM reset in Stage parameter;
- CDRF_NOTIFYPOSTERASE - usually can be used to provide default erasing,
- if you want to perform drawing immediately after that;
- CDRF_NOTIFYPOSTPAINT - return this value to provide calling the event
- after performing default drawing. Useful when you wish
- redraw only a part of the (sub)item;
- CDRF_SKIPDEFAULT - return this value to inform the system that all
- drawing is done and system should not peform any more
- drawing for the (sub)item during this drawing cycle.
- CDRF_NEWFONT - informs the system, that font is changed and default
- drawing should be performed with changed font;
- |</pre>
- If you want to get notifications for each subitem, do not use option
- lvoOwnerDrawFixed, because such style prevents system from notifying
- the application for each subitem to be drawn in the listview and only
- notifications will be sent about entire items.
- |<br>
- See also NM_CUSTOMDRAW in API Help.
- }
-
- procedure Set_LVItemHeight(Value: Integer);
- function SetLVItemHeight(Value: Integer): PControl;
- property LVItemHeight: Integer read fLVItemHeight write Set_LVItemHeight;
- {* |<#listview>
- |<#listbox>
- |#combo>
- It is possible to assign a value to LVItemHeight property only to
- control with "owner-draw" style (lvoOwnerDrawFixed for listview,
- loOwnerDrawFixed or loOwnerDrawVariable for listbox and
- coOwnerDrawFixed or coOwnerDrawVariable for combobox. At least, the
- control should have such option while creating it (after showing it
- the first time it is possible to change its options to avoid owner
- drawing later). }
-
- //======== TreeView specific properties and methods:
- function TVInsert( nParent, nAfter: THandle; const Txt: KOLString ): THandle;
- {* |<#treeview>
- Inserts item to a tree view. If nParent is 0 or TVI_ROOT, the item is
- inserted at the root of tree view. It is possible to pass following special
- values as nAfter parameter:
- |<pre>
- TVI_FIRST Inserts the item at the beginning of the list.
- TVI_LAST Inserts the item at the end of the list.
- TVI_SORT Inserts the item into the list in alphabetical order.
- |</pre> }
- procedure TVDelete( Item: THandle );
- {* |<#treeview>
- Removes an item from the tree view. If value TVI_ROOT is passed, all items
- are removed. }
-
- property TVSelected: THandle index TVGN_CARET read TVGetItemIdx write TVSetItemIdx;
- {* |<#treeview>
- Returns or sets currently selected item handle in tree view. }
-
- property TVDropHilighted: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
- {* |<#treeview>
- Returns or sets item, which is currently highlighted as a drop target. }
- property TVDropHilited: THandle index TVGN_DROPHILITE read TVGetItemIdx write TVSetItemIdx;
- {* The same as TVDropHilighted. }
- property TVFirstVisible: THandle index TVGN_FIRSTVISIBLE read TVGetItemIdx write TVSetItemIdx;
- {* |<#treeview>
- Returns or sets given item to top of tree view. }
-
- property TVIndent: Integer index TVM_GETINDENT read GetIntVal write SetIntVal;
- {* |<#treeview>
- The amount, in pixels, that child items are indented relative to their
- parent items. }
- property TVVisibleCount: Integer index TVM_GETVISIBLECOUNT read GetIntVal;
- {* |<#treeview>
- Returns number of fully (not partially) visible items in tree view. }
-
- property TVRoot: THandle index TVGN_ROOT read TVGetItemIdx;
- {* |<#treeview>
- Returns handle of root item in tree view (or 0, if tree is empty). }
- property TVItemChild[ Item: THandle ]: THandle index TVGN_CHILD read TVGetItemNext;
- {* |<#treeview>
- Returns first child item for given one. }
- property TVItemHasChildren[ Item: THandle ]: Boolean read TV_GetItemHasChildren write TV_SetItemHasChildren;
- {* |<#treeview>
- TRUE, if an Item has children. Set this value to true if you want to
- force [+] sign appearing left from the node, even if there are no
- subnodes added to the node yet. }
- property TVItemChildCount[ Item: THandle ]: Integer read TV_GetItemChildCount;
- {* |<#treeview>
- Returns number of node child items in tree view.
- }
- property TVItemNext[ Item: THandle ]: THandle index TVGN_NEXT read TVGetItemNext;
- {* |<#treeview>
- Returns next sibling item handle for given one (or 0, if passed item is
- the last child for its parent node). }
- property TVItemPrevious[ Item: THandle ]: THandle index TVGN_PREVIOUS read TVGetItemNext;
- {* |<#treeview>
- Returns previous sibling item (or 0, if the is no such item). }
- property TVItemNextVisible[ Item: THandle ]: THandle index TVGN_NEXTVISIBLE read TVGetItemNext;
- {* |<#treeview>
- Returns next visible item (passed item must be visible too, to determine,
- if it is really visible, use property TVItemRect or TVItemVisible. }
- property TVItemPreviousVisible[ Item: THandle ]: THandle index TVGN_PREVIOUSVISIBLE read TVGetItemNext;
- {* |<#treeview>
- Returns previous visible item. }
- property TVItemParent[ Item: THandle ]: THandle index TVGN_PARENT read TVGetItemNext;
- {* |<#treeview>
- Returns parent item for given one (or 0 for root item). }
-
- property TVItemText[ Item: THandle ]: KOLString read TVGetItemText write TVSetItemText;
- {* |<#treeview>
- Text of tree view item. }
- function TVItemPath( Item: THandle; Delimiter: KOLChar ): KOLString;
- {* |<#treeview>
- Returns full path from the root item to given item. Path is calculated
- as a concatenation of all parent nodes text strings, separated by
- given delimiter character.
- |<br>Please note, that returned path has no trailing delimiter, this
- character is only separating different parts of the path.
- |<br>If Item is not specified ( =0 ), path is returned
- for Selected item. }
-
- property TVItemRect[ Item: THandle; TextOnly: Boolean ]: TRect read TVGetItemRect;
- {* |<#treeview>
- Returns rectangle, occupied by an item in tree view. }
-
- property TVItemVisible[ Item: THandle ]: Boolean read TVGetItemVisible write TVSetITemVisible;
- {* |<#treeview>
- Returs True, if item is visible in tree view. It is also possible to
- assign True to this property to ensure that a tree view item is visible
- (if False is assigned, this does nothing). }
- function TVItemAtPos( x, y: Integer; var Where: DWORD ): THandle;
- {* |<#treeview>
- Returns handle of item found at specified position (relative to upper left
- corener of client area of the tree view). If no item found, 0 is returned.
- Variable Where receives additional flags combination, describing more
- detailed, on which part of item or tree view given point is located,
- such as:
- |<pre>
- TVHT_ABOVE Above the client area
- TVHT_BELOW Below the client area
- TVHT_NOWHERE In the client area, but below the last item
- TVHT_ONITEM On the bitmap or label associated with an item
- TVHT_ONITEMBUTTON On the button associated with an item
- TVHT_ONITEMICON On the bitmap associated with an item
- TVHT_ONITEMINDENT In the indentation associated with an item
- TVHT_ONITEMLABEL On the label (string) associated with an item
- TVHT_ONITEMRIGHT In the area to the right of an item
- TVHT_ONITEMSTATEICON On the state icon for a tree-view item that is in a user-defined state
- TVHT_TOLEFT To the right of the client area
- TVHT_TORIGHT To the left of the client area
- |</pre> }
-
- property TVRightClickSelect: Boolean read fTVRightClickSelect write SetTVRightClickSelect;
- {* |<#treeview>
- Set this property to True to allow change selection to an item, clicked with right mouse button. }
- property TVEditing: Boolean read fEditing;
- {* |<#treeview>
- Returns True, if tree view control is editing its item label. }
-
- property TVItemBold[ Item: THandle ]: Boolean index TVIS_BOLD read TVGetItemStateFlg write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item is bold. }
- property TVItemCut[ Item: THandle ]: Boolean index TVIS_CUT read TVGetITemStateFlg write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item is selected as part of "cut and paste" operation. }
- property TVItemDropHighlighted[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item is selected as drop target. }
- property TVItemDropHilited[ Item: THandle ]: Boolean index TVIS_DROPHILITED read TVGetITemStateFlg write TVSetItemStateFlg;
- {* The same as TVItemDropHighlighted. }
- property TVItemExpanded[ Item: THandle ]: Boolean index TVIS_EXPANDED read TVGetITemStateFlg; // write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item's list of child items is currently expanded. To change
- expanded state, use method TVExpand. }
- property TVItemExpandedOnce[ Item: THandle ]: Boolean index TVIS_EXPANDEDONCE read TVGetITemStateFlg; // write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item's list of child items has been expanded at least once. }
- property TVItemSelected[ Item: THandle ]: Boolean index TVIS_SELECTED read TVGetITemStateFlg write TVSetItemStateFlg;
- {* |<#treeview>
- True, if item is selected. }
-
- procedure TVExpand( Item: THandle; Flags: DWORD );
- {* |<#treeview>
- Call it to expand/collapse item's child nodes. Possible values for Flags
- parameter are:
- <pre>
- TVE_COLLAPSE Collapses the list.
- TVE_COLLAPSERESET Collapses the list and removes the child items. Note
- that TVE_COLLAPSE must also be specified.
- TVE_EXPAND Expands the list.
- TVE_TOGGLE Collapses the list if it is currently expanded or
- expands it if it is currently collapsed.
- </pre>
- }
- procedure TVSort( N: THandle );
- {* |<#treeview>
- By Alex Mokrov. Sorts treeview. If N = 0, entire treeview is sorted.
- Otherwise, children of the given node only.
- }
-
- property TVItemImage[ Item: THandle ]: Integer index TVIF_IMAGE read TVGetItemImage write TVSetItemImage;
- {* |<#treeview>
- Image index for an item of tree view. To tell that there are no image
- set, use index -2 (value -1 is reserved for callback image). }
- property TVItemSelImg[ Item: THandle ]: Integer index TVIF_SELECTEDIMAGE read TVGetItemImage write TVSetItemImage;
- {* |<#treeview>
- Image index for an item of tree view in selected state. Use value -2 to
- provide no image, -1 used for callback image. }
- property TVItemOverlay[ Item: THandle ]: Integer index TVIS_OVERLAYMASK or $80000
- read TVGetItemImage write TVSetItemImage;
- {* |<#treeview>
- Overlay image index for an item in tree view.
- Values 1..15 can be used only - this is the Windows restriction on
- overlay images. }
- property TVItemStateImg[ Item: THandle ]: Integer index TVIS_STATEIMAGEMASK or $C0000
- read TVGetItemImage write TVSetItemImage;
- {* |<#treeview>
- State image index for an item in tree view. Use 1-based index of the image
- in image list ImageListState. Value 0 reserved to use as "no state image".
- }
-
- property TVItemData[ Item: THandle ]: Pointer read TVGetItemData write TVSetItemData;
- {* |<#treeview>
- Stores any program-defined pointer with the item. }
- procedure TVEditItem( Item: THandle );
- {* |<#treeview>
- Begins editing given item label in tree view. }
- procedure TVStopEdit( Cancel: Boolean );
- {* |<#treeview>
- Ends editing item label, started by user or explicitly by TVEditItem method. }
-
- property OnTVBeginDrag: TOnTVBeginDrag read fOnTVBeginDrag write fOnTVBeginDrag;
- {* |<#treeview>
- Is called for tree view, when its item is to be dragging. }
- property OnTVBeginEdit: TOnTVBeginEdit read fOnTVBeginEdit write fOnTVBeginEdit;
- {* |<#treeview>
- Is called for tree view, when its item label is to be editing. }
- property OnTVEndEdit: TOnTVEndEdit read fOnTVEndEdit write fOnTVEndEdit;
- {* |<#treeview>
- Is called when item label is edited. It is possible to cancel
- edit, returning False as a result. }
- property OnTVExpanding: TOnTVExpanding read fOnTVExpanding write fOnTVExpanding;
- {* |<#treeview>
- Is called just before expanding/collapsing item. It is possible to
- return TRUE to prevent expanding item, otherwise FALSE should be returned. }
- property OnTVExpanded: TOnTVExpanded read fOnTVExpanded write fOnTVExpanded;
- {* |<#treeview>
- Is called after expanding/collapsing item children. }
- property OnTVDelete: TOnTVDelete read fOnTVDelete write SetOnTVDelete;
- {* |<#treeview>
- Is called just before deleting item. You may use this event to free
- resources, associated with an item (see TVItemData property). }
- //----------------- by Sergey Shisminzev:
- property OnTVSelChanging: TOnTVSelChanging read fOnTVSelChanging write fOnTVSelChanging;
- {* |<#treeview>
- Is called before changing the selection. The handler can return FALSE
- to prevent changing the selection. }
- //--------------------------------------
-
- //======== Toolbar specific methods:
- procedure TBAddBitmap( Bitmap: HBitmap );
- {* |<#toolbar>
- Adds bitmaps to a toolbar. You can pass special values as Bitmap to
- add one of predefined system button images bitmaps:
- |<br> THandle(-1) to add standard small icons,
- |<br> THandle(-2) to add standard large icons,
- |<br> THandle(-5) to add standard small view icons,
- |<br> THandle(-6) to add standard large view icons,
- |<br> THandle(-9) to add standard small history icons,
- |<br> THandle(-10) to add standard large history icons,
- (in that case use following values as indexes to the standard and view
- bitmaps:
- |<br>
- STD_COPY, STD_CUT, STD_DELETE, STD_FILENEW, STD_FILEOPEN, STD_FILESAVE,
- STD_FIND, STD_HELP, STD_PASTE, STD_PRINT, STD_PRINTPRE, STD_PROPERTIES,
- STD_REDO, STD_REPLACE, STD_UNDO,
- |<br>
- VIEW_LARGEICONS, VIEW_SMALLICONS,
- VIEW_LIST, VIEW_DETAILS, VIEW_SORTNAME, VIEW_SORTSIZE, VIEW_SORTDATE,
- VIEW_SORTTYPE (use it as parameters BtnImgIdxArray in TBAddButtons or
- TBInsertButtons methods, and in assigning value to TBButtonImage[ ]
- property).
- Added bitmaps have indeces starting from previous count of images
- (as these are appended to existing - if any).
- |<br>
- Note, that if You add your own (custom) bitmap, it is not transparent.
- Do not assume that clSilver is always equal to clBtnFace. Use API
- function CreateMappedBitmap to load bitmap from resource and map
- desired colors as you wish (e.g., convert clTeal to clBtnFace). Or,
- call defined in KOL function LoadMappedBitmap to do the same more easy.
- Unfortunately, resource identifier for bitmap to pass it to LoadMappedBitmap
- or to CreateMappedBitmap seems must be integer, so it is necessary to
- create rc-file manually and compile using Borland Resource Compiler to
- figure it out. }
-
- function TBAddButtons( const Buttons: array of PKOLChar; const BtnImgIdxArray: array
- of Integer ): Integer;
- {* |<#toolbar>
- Adds buttons to toolbar. Last string in Buttons array *must* be empty
- ('' or nil), so to add buttons without text, pass ' ' string (one space
- char). It is not necessary to provide image indexes for all
- buttons (it is sufficient to assign index for first button only).
- But in place, correspondent to separator button (defined by string '-'),
- any integer must be passed to assign follow image indexes correctly.
- See example.
- |*Toolbar adding buttons sample.
- Code below shows how to call TBAddButtons method to add two buttons with
- a separator between these buttons. idxNew and idxOld are integer
- expressions assigning image indexes to buttons 'New' and 'Old'. This
- indexes are zero-based and refer to bitmap images, added earlier (either
- in creating toolbar by call of NewToolbar or later in call of TBAddBitmap).
- !
- ! TBAddButtons( [ '&New', '-', '&Old', '' ], [ idxNew, 0, idxOld ] );
- !
- |*
- To add check buttons, use prefix '+' or '-' in button definition
- string. If next character is '!', such buttons are grouped to a
- radio-group. Also, it is possible to use '^' prefix (must be first) to
- define button with small drop-down section (use also OnTBDropDown event
- to respond to clicking drop down section of such buttons).
- |<br>
- This function returns command id for first added button (other
- id's can be calculated incrementing the result by one for each
- button, except separators, which have no command id).
- |<br>
- Note: for static toolbar (single in application and created
- once) ids are started from value 100. }
-
- function TBInsertButtons( BeforeIdx: Integer; Buttons: array of PKOLChar;
- BtnImgIdxArray: array of Integer ): Integer;
- {* |<#toolbar>
- Inserts buttons before button with given index on toolbar. Returns
- command identifier for first button inserted (other can be calculated
- incrementing returned value needed times. See also TBAddButtons. }
-
- procedure TBDeleteButton( BtnID: Integer );
- {* |<#toolbar>
- Deletes single button given by its command id. To delete separator,
- use TBDeleteBtnByIdx instead. }
-
- procedure TBDeleteBtnByIdx( Idx: Integer );
- {* |<#toolbar>
- Deletes single button given by its index in toolbar (not by command ID). }
-
- procedure TBAssignEvents( BtnID: Integer; Events: array of TOnToolbarButtonClick );
- {* |<#toolbar>
- Allows to assign separate OnClick events for every toolbar button.
- BtnID should be toolbar button ID or index of the first button to
- assign event. If it is an ID, events are assigned to buttons in
- creation order. Otherwise, events are assigned in placement order.
- Anyway, separator buttons are not skipped, so pass at least nil for such
- button as an event.
- |<br>
- Please note, that though not all buttons should exist before
- assigning events to it, therefore at least the first button
- (specified by BtnID) must be already added before calling TBAssignEvents. }
-
- procedure TBResetImgIdx( BtnID, BtnCount: Integer );
- {* |<#toolbar>
- Resets image index for BtnCount buttons starting from BtnID. }
-
- property CurItem: Integer read fCurItem;
- {* |<#toolbar>
- For toolbar, in OnClick event this property can be used to determine
- which button was clicked (100-based button id in toolbar). It is also
- possible to use CurIndex property (zero-based) for this purpose as
- well, but do not assume, that CurItem always equal to CurIndex+100.
- At least, it is possible to call TBItem2Index function to convert
- button ID to its index in toolbar.
- }
-
- property TBButtonCount: Integer read GetItemsCount; //TBGetButtonCount;
- {* |<#toolbar>
- Returns count of buttons on toolbar. The same as Count. }
-
- property TBBtnImgWidth: Integer read fTBBtnImgWidth write fTBBtnImgWidth;
- {* |<#toolbar>
- Custom toolbar buttons width. Set it before assigning buttons bitmap.
- Changing this property after assigning the bitmap has no effect. }
-
- function TBItem2Index( BtnID: Integer ): Integer;
- {* |<#toolbar>
- Converts button command id to button index for tool bar. }
-
- function TBIndex2Item( Idx: Integer ): Integer;
- {* |<#toolbar>
- Converts toolbar button index to its command ID. }
-
- procedure TBConvertIdxArray2ID( const IdxVars: array of PDWORD );
- {* |<#toolbar>
- Converts toolbar button indexes to its command IDs for an array
- of indexes (each item in the array passed is a pointer to
- Integer, containing button index when the procedure is callled,
- then all these indexes are relaced with a correspondent button ID).}
-
- property TBButtonEnabled[ BtnID: Integer ]: Boolean index TB_ENABLEBUTTON
- read TBGetBtnStt write TBSetBtnStt;
- {* |<#toolbar>
- Obvious. }
-
- property TBButtonVisible[ BtnID: Integer ]: Boolean read TBGetButtonVisible
- write TBSetButtonVisible;
- {* |<#toolbar>
- Allows to hide/show some of toolbar buttons. }
-
- property TBButtonChecked[ BtnID: Integer ]: Boolean index TB_CHECKBUTTON
- read TBGetBtnStt write TBSetBtnStt;
- {* |<#toolbar>
- Allows to determine 'checked' state of a button (e.g., radio-button),
- and to check it programmatically. }
- {$ifdef win32}
- property TBButtonMarked[ BtnID: Integer ]: Boolean index TB_MARKBUTTON
- read TBGetBtnStt write TBSetBtnStt;
- {* |<#toolbar>
- Returns True if toolbar button is marked (highlighted). Allows to
- highlight buttons assigning True to this value. }
- {$endif}
- property TBButtonPressed[ BtnID: Integer ]: Boolean index TB_PRESSBUTTON
- read TBGetBtnStt write TBSetBtnStt;
- {* |<#toolbar>
- Allows to detrmine if toolbar button (given by its command ID) pressed,
- and press/unpress it programmatically. }
-
- property TBButtonText[ BtnID: Integer ]: KOLString read TBGetButtonText write TBSetButtonText;
- {* |<#toolbar>
- Obtains toolbar button text and allows to change it. Be sure that text
- is not empty for all buttons, if You want for it to be shown (if at least
- one button has empty text, no text labels will be shown at all). At
- least set it to ' ' for buttons, which You do not want to show labels,
- if You want from other ones to have it. }
-
- property TBButtonImage[ BtnID: Integer ]: Integer read TBGetBtnImgIdx write TBSetBtnImgIdx;
- {* |<#toolbar>
- Allows to access/change button image. Do not read this property for
- separator buttons, returning value is not proper. If you do not know,
- is the button a separator, using function below. }
-
- function TBButtonSeparator( BtnID: Integer ): Boolean;
- {* |<#toolbar>
- Returns TRUE, if a toolbar button is separator. }
-
- property TBButtonRect[ BtnID: Integer ]: TRect read TBGetButtonRect;
- {* |<#toolbar>
- Obtains rectangle occupied by toolbar button in toolbar window.
- (It is not possible to obtain rectangle for buttons, currently
- not visible). See also function ToolbarButtonRect. }
-
- property TBButtonWidth[ BtnID: Integer ]: Integer read TBGetBtnWidth write TBSetBtnWidth;
- {* |<#toolbar>
- Allows to obtain / change toolbar button width. }
-
- property TBButtonsMinWidth: Integer index 0
- {$IFDEF F_P} read TBGetBtMinMaxWidth
- {$ELSE DELPHI} read FTBBtMinWidth
- {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
- {* |<#toolbar>
- Allows to set minimal width for all toolbar buttons. }
- property TBButtonsMaxWidth: Integer index 1
- {$IFDEF F_P} read TBGetBtMinMaxWidth
- {$ELSE DELPHI} read FTBBtMaxWidth
- {$ENDIF F_P/DELPHI} write TBSetBtMinMaxWidth;
- {* |<#toolbar>
- Allows to set maximal width for all toolbar buttons. }
-
- function TBButtonAtPos( X, Y: Integer ): Integer;
- {* |<#toolbar>
- Returns command ID of button at the given position on toolbar,
- or -1, if there are no button at the position. Value 0 is returned
- for separators. }
-
- function TBBtnIdxAtPos( X, Y: Integer ): Integer;
- {* |<#toolbar>
- Returns index of button at the given position on toolbar.
- This also can be index of separator button. -1 is returned if
- there are no buttons found at the position. }
-
- function TBMoveBtn( FromIdx, ToIdx: Integer ): Boolean;
- {* |<#toolbar>
- By TR"]F. Moves button from one position to another. }
-
- property TBRows: Integer read TBGetRows write TBSetRows;
- {* |<#toolbar>
- Returns number of rows for toolbar and allows to try to set
- desired number of rows (but system can set another number of
- rows in some cases). This property has no effect if tboWrapable
- style not present in Options when toolbar is created. }
-
- procedure TBSetTooltips( BtnID1st: Integer; const Tooltips: array of PKOLChar );
- {* |<#toolbar>
- Allows to assign tooltips to several buttons. Until this procedure
- is not called, tooltips list is not created and no code is added
- to executable. This method of tooltips maintainance for toolbar buttons
- is useful both for static and dynamic toolbars (meaning "dynamic" -
- toolbars with buttons, deleted and inserted at run-time). }
-
- property OnTBDropDown: TOnEvent read fOnDropDown write fOnDropDown;
- {* |<#toolbar>
- This event is called for drop down buttons, when user click drop part
- of drop down button. To determine for which button event is called,
- look at CurItem or CurIndex property. It is also possible to use
- common (with combobox) property OnDropDown. }
-
- property OnTBClick: TOnEvent read fOnClick write fOnClick;
- {* |<#toolbar>
- The same as OnClick. }
- {$ifndef wince}
- property OnTBCustomDraw: TOnTBCustomDraw read fOnTBCustomDraw write SetOnTBCustomDraw;
- {* |<#toolbar>
- An event (mainly) to customize toolbar background. }
- {$endif wince}
- property MaxTextSize: DWORD read GetMaxTextSize write SetMaxTextSize;
- {* |<#richedit>
- This property valid also for simple edit control, not only for RichEdit.
- But for usual edit control, maximum text size available is 32K. For
- RichEdit, limit is 4Gb. By default, RichEdit is limited to
- 32767 bytes (to set maximum size available to 2Gb, assign MaxInt value
- to a property). Also, to get current text size of RichEdit, use property
- TextSize or RE_TextSize[ ]. }
- property TextSize: Integer read GetTextSize;
- {* |<#richedit>
- Common for edit and rich edit controls property, which returns size of
- text in edit control. Also, for any other control (or form, or applet
- window) returns size (in characters) of Caption or Text (what is, the
- same property actually). }
- //================== RichEdit specific: ==================
- {$IFNDEF NOT_USE_RICHEDIT}
- property RE_TextSize[ Units: TRichTextSize ]: Integer read REGetTextSize;
- {* |<#richedit>
- For RichEdit control, it returns text size, measured in desired units
- (rtsChars - characters, including OLE objects, counted as a single
- character; rtsBytes - presize length of text image (if it would be stored
- in file or stream). Please note, that for RichEdit1.0, only size in
- characters can be obtained. }
- function RE_TextSizePrecise: Integer;
- {* |<#richedit>
- By Savva. Returns length of rich edit text. }
-
- property RE_CharFmtArea: TRichFmtArea read fRECharArea write fRECharArea;
- {* |<#richedit>
- By default, this property is raSelection. Changing it, You determine in
- for which area characters format is applyed, when changing
- character formatting properties below (not paragraph formatting).
- |&A=<a href=#RE_CharFmtArea target=main>%0</a>
- }
- property RE_CharFormat: TCharFormat read REGetCharformat write RESetCharFormat;
- {* |<#richedit>
- In differ to follow properties, which allow to control certain formatting
- attributes, this property provides low level access for formatting current
- character area (see RE_CharFmtArea). It returns TCharFormat structure,
- filled in with formatting attributes, and by assigning another value to
- this property You can change desired attributes as You wish. Even if
- RichEdit1.0 is used, TCharFormat2 is returned (but extended fields are
- ignored for RichEdit1.0). }
- property RE_Font: PGraphicTool read REGetFont write RESetFont;
- {* |<#richedit>
- Font of the first character in current selection (when retrieve).
- When set (or subproperties of RE_Font are set), all font attributes are
- applied to entire <A area>. To apply only needed attributes, use another
- properties: RE_FmtBold, RE_FmtItalic, RE_FmtStrikeout, RE_FmtUnderline,
- RE_FmtName, etc.
- |<br>
- Note, that font size is measured in twips, which is about 1/10 of pixel. }
- property RE_FmtBold: Boolean index CFM_BOLD read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Formatting flag. When retrieve, returns True, if fsBold style RE_Font.FontStyle
- is valid for a first character in the selection. When set, changes fsBold
- style (True - set, False - reset) for all characters in <A area>. }
- property RE_FmtBoldValid: Boolean index CFM_BOLD read REGetFontMask;
- {* }
- property RE_FmtItalic: Boolean index CFM_ITALIC read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsItalic
- style valid for the first character of the selection, and when set, changes
- only fsItalic style for an <A area>. }
- property RE_FmtItalicValid: Boolean index CFM_ITALIC read REGetFontMask;
- {* }
- property RE_FmtStrikeout: Boolean index CFM_STRIKEOUT read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsStrikeout
- style valid for the first selected character, and when set, changes only
- fsStrikeout style for an <A area>. }
- property RE_FmtStrikeoutValid: Boolean index CFM_STRIKEOUT read REGetFontMask;
- {* }
- property RE_FmtUnderline: Boolean index CFM_UNDERLINE read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Formatting flag. Like RE_FmtBold, when retrieving, shows, is fsUnderline
- style valid for the first selected character, and when set, changes
- fsUnderline style for an <A area>. }
- property RE_FmtUnderlineValid: Boolean index CFM_UNDERLINE read REGetFontMask;
- {* }
- property RE_FmtUnderlineStyle: TRichUnderline
- read REGetUnderlineEx write RESetUnderlineEx;
- {* |<#richedit>
- Extended underline style. To check, if this property is valid for
- entire selection, examine RE_FmtUnderlineValid value. }
- property RE_FmtProtected: Boolean index CFM_PROTECTED read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Formatting flag. When retrieving, shows, is the first character of the selection
- is protected from changing it by user (True) or not (False). To get know,
- if retrived value is valid for entire selection, check the property
- RE_FmtProtectedValid. When set, makes all characters in <A area> protected (
- True) or not (False). }
- property RE_FmtProtectedValid: Boolean index CFM_PROTECTED read REGetFontMask;
- {* |<#richedit>
- True, if property RE_FmtProtected is valid for entire selection, when
- retrieving it. }
- property RE_FmtHidden: Boolean index CFM_HIDDEN read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- For RichEdit3.0, makes text hidden (not displayed). }
- property RE_FmtHiddenValid: Boolean index CFM_HIDDEN read REGetFontMask;
- {* |<#richedit>
- Returns True, if RE_FmtHidden style is valid for entire selection. }
-
- property RE_FmtLink: Boolean index $20 {CFM_LINK} read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- Returns True, if the first selected character is a part of link (URL). }
- // by Sergey Shisminzev
-
- property RE_FmtLinkValid: Boolean index $20 {CFM_LINK} read REGetFontMask;
- {* }
- property RE_FmtFontSize: Integer index (12 shl 16) or CFM_SIZE read REGetFontAttr write RESetFontAttr;
- {* |<#richedit>
- Formatting value: font size, in twips (1/1440 of an inch, or 1/20 of a
- printer's point, or about 1/10 of pixel). When retrieving, returns
- RE_Font.FontHeight.
- When set, changes font size for entire <A area> (but does not change
- other font attributes). }
- property RE_FmtFontSizeValid: Boolean read REGetFontSizeValid;
- {* |<#richedit>
- Returns True, if property RE_FmtFontSize is valid for entire selection,
- when retrieving it. }
- property RE_FmtAutoBackColor: Boolean index CFM_BACKCOLOR read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- True, when automatic back color is used. }
- property RE_FmtAutoBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
- {* }
- property RE_FmtFontColor: Integer index (20 shl 16) or CFM_COLOR read REGetFontAttr write RESetFontAttr1;
- {* |<#richedit>
- Formatting value (font color). When retrieving, returns RE_Font.Color.
- When set, changes font color for entire <A area> (but does not change
- other font attributes). }
- property RE_FmtFontColorValid: Boolean index CFM_COLOR read REGetFontMask;
- {* |<#richedit>
- Returns True, if property RE_FmtFontColor valid for entire selection,
- when retrieving it. }
- property RE_FmtAutoColor: Boolean index CFM_COLOR read REGetFontEffects write RESetFontEffect;
- {* |<#richedit>
- True, when automatic text color is used (in such case, RE_FmtFontColor
- assignment is ignored for current area). }
- property RE_FmtAutoColorValid: Boolean index CFM_COLOR read REGetFontMask;
- {* }
- property RE_FmtBackColor: Integer index ((64
- {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF}
- ) shl 16) or CFM_BACKCOLOR read REGetFontAttr write RESetFontAttr1;
- {* |<#richedit>
- Formatting value (back color). Only available for Rich Edit 2.0 and higher.
- When set, changes background color for entire <A area> (but does not change
- other font attributes). }
- property RE_FmtBackColorValid: Boolean index CFM_BACKCOLOR read REGetFontMask;
- {* }
- property RE_FmtFontOffset: Integer index (16 shl 16) or CFM_OFFSET read REGetFontAttr write RESetFontAttr;
- {* |<#richedit>
- Formatting value (font vertical offset from baseline, positive values
- correspond to subscript). When retrieving, returns offset for first
- character in the selection. When set, changes font offset for entire
- <A area>. To get know, is retrieved value valid for entire selction,
- check RE_FmtFontOffsetValid property. }
- property RE_FmtFontOffsetValid: Boolean index CFM_OFFSET read REGetFontMask;
- {* |<#richedit>
- Returns True, if property RE_FmtFontOffset is valid for entire selection,
- when retrieving it. }
- property RE_FmtFontCharset: Integer index (25 shl 16) or CFM_CHARSET read REGetFontAttr write RESetFontAttr;
- {* |<#richedit>
- Returns charset for first character in current selection, when retrieved
- (and to get know, if this value is valid for entire selection, check
- property RE_FmtFontCharsetValid). When set, changes charset for all
- characters in <A area>, but does not alter other formatting attributes. }
- property RE_FmtFontCharsetValid: Boolean index CFM_CHARSET read REGetFontMask;
- {* |<#richedit>
- Returns True, only if rerieved property RE_FmtFontCharset is valid for
- entire selection. }
- property RE_FmtFontName: KOLString read REGetFontName write RESetFontName;
- {* |<#richedit>
- Returns font face name for first character in the selection, when retrieved,
- and sets font name for entire <A area>, wnen assigned to (without
- changing of other formatting attributes). To get know, if retrived
- font name valid for entire selection, examine property RE_FmtFontNameValid. }
- property RE_FmtFontNameValid: Boolean index CFM_FACE read REGetFontMask;
- {* |<#richedit>
- Returns True, only if the font name is the same for entire selection,
- thus is, if rerieved property value RE_FmtFontName is valid for entire
- selection. }
-
- property RE_ParaFmt: TParaFormat read REGetParaFmt write RESetParaFmt;
- {* |<#richedit>
- Allows to retrieve or set paragraph formatting attributes for currently
- selected paragraph(s) in RichEdit control. See also following properties,
- which allow to do the same for certain paragraph format attributes
- separately. }
- property RE_TextAlign: TRichTextAlign read REGetTextAlign write RESetTextAlign;
- {* |<#richedit>
- Returns text alignment for current selection and allows to change it
- (without changing other formatting attributes). }
- property RE_TextAlignValid: Boolean index PFM_ALIGNMENT read REGetParaAttrValid;
- {* |<#richedit>
- Returns True, if property RE_TextAlign is valid for entire selection. If
- False, it is concerning only start of selection. }
- property RE_Numbering: Boolean read REGetNumbering write RESetNumbering;
- {* |<#richedit>
- Returns True, if selected text is numbered (or has style of list with
- bullets). To get / change numbering style, see properties
- RE_NumStyle and RE_NumBrackets. }
- property RE_NumStyle: TRichNumbering read REGetNumStyle write RESetNumStyle;
- {* |<#richedit>
- Advanced numbering style, such as rnArabic etc. If You use it, do not
- change RE_Numbering property simultaneously - this can cause changing
- style to rnBullets only. }
- property RE_NumStart: Integer read REGetNumStart write RESetNumStart;
- {* |<#richedit>
- Starting number for advanced numbering style. If this property is not
- set, numbering is starting by default from 0. For rnLRoman and rnURoman
- this cause, that first item has no number to be shown (ancient Roman
- people did not invent '0'). }
- property RE_NumBrackets: TRichNumBrackets read REGetNumBrackets write RESetNumBrackets;
- {* |<#richedit>
- Brackets style for advanced numbering. rnbPlain is default
- brackets style, and every time, when RE_NumStyle is changed,
- RE_NumBrackets is reset to rnbPlain. }
- property RE_NumTab: Integer read REGetNumTab write RESetNumTab;
- {* |<#richedit>
- Tab between start of number and start of paragraph text. If too small too
- view number, number is not displayed. (Default value seems to be sufficient
- though). }
- property RE_NumberingValid: Boolean index PFM_NUMBERING read REGetParaAttrValid;
- {* |<#richedit>
- Returns True, if RE_Numbering, RE_NumStyle, RE_NumBrackets, RE_NumTab,
- RE_NumStart properties are valid for entire selection. }
- property RE_Level: Integer read REGetLevel;
- {* |<#richedit>
- Outline level (for numbering paragraphs?). Read only. }
- property RE_SpaceBefore: Integer index 0 or PFM_SPACEBEFORE read REGetSpacing write RESetSpacing;
- {* |<#richedit>
- Spacing before paragraph. }
- property RE_SpaceBeforeValid: Boolean index PFM_SPACEBEFORE read REGetParaAttrValid;
- {* |<#richedit>
- True, if RE_SpaceBefore value is valid for all selected paragraph (if
- False, this value is valid only for first paragraph. }
- property RE_SpaceAfter: Integer index 4 or PFM_SPACEAFTER read REGetSpacing write RESetSpacing;
- {* |<#richedit>
- Spacing after paragraph. }
- property RE_SpaceAfterValid: Boolean index PFM_SPACEAFTER read REGetParaAttrValid;
- {* |<#richedit>
- True, only if RE_SpaceAfter value is valid for all selected paragraphs. }
- property RE_LineSpacing: Integer index 8 or PFM_LINESPACING read REGetSpacing write RESetSpacing;
- {* |<#richedit>
- Linespacing in paragraph (this value is based on RE_SpacingRule property). }
- property RE_SpacingRule: Integer read REGetSpacingRule write RESetSpacingRule;
- {* |<#richedit>
- Linespacing rule. Do not know what is it. }
- property RE_LineSpacingValid: Boolean index PFM_LINESPACING read REGetParaAttrValid;
- {* |<#richedit>
- True, only if RE_LineSpacing and RE_SpacingRule values are valid for
- entire selection. }
- property RE_Indent: Integer index (20 shl 16) or PFM_OFFSET read REGetParaAttr write RESetParaAttr;
- {* |<#richedit>
- Returns left indentation for paragraph in current selection and allows
- to change it (without changing other formatting attributes). }
- property RE_IndentValid: Boolean index PFM_OFFSET read REGetParaAttrValid;
- {* |<#richedit>
- Returns True, if RE_Indent property is valid for entire selection. }
- property RE_StartIndent: Integer index (12 shl 16) or PFM_STARTINDENT read REGetParaAttr write RESetParaAttr;
- {* |<#richedit>
- Returns left indentation for first line in paragraph for current
- selection, and allows to change it (without changing other formatting
- attributes). }
- property RE_StartIndentValid: Boolean read REGetStartIndentValid;
- {* |<#richedit>
- Returns True, if property RE_StartIndent is valid for entire selection. }
- property RE_RightIndent: Integer index (16 shl 16) or PFM_RIGHTINDENT read REGetParaAttr write RESetParaAttr;
- {* |<#richedit>
- Returns right indent for paragraph in current selection, and allow to
- change it (without changing other formatting attributes). }
- property RE_RightIndentValid: Boolean index PFM_RIGHTINDENT read REGetParaAttrValid;
- {* |<#richedit>
- Returns True, if property RE_RightIndent is valid for entire selection only. }
- property RE_TabCount: Integer read REGetTabCount write RESetTabCount;
- {* |<#richedit>
- Number of tab stops in current selection. This value can not be set greater
- then MAX_TAB_COUNT (32). }
- property RE_Tabs[ Idx: Integer ]: Integer read REGetTabs write RESetTabs;
- {* |<#richedit>
- Tab stops for RichEdit control. }
- property RE_TabsValid: Boolean index PFM_TABSTOPS read REGetParaAttrValid;
- {* |<#richedit>
- Returns True, if properties RE_Tabs[ ] and RE_TabCount are valid for
- entire selection. }
-
- // following does not work now :
- property RE_BorderWidth[ Side: TBorderEdge ]: Integer index 2 read REGetBorder write RESetBorder;
- { * |<#richedit>
- Border width. }
- property RE_BorderSpace[ Side: TBorderEdge ]: Integer index 0 read REGetBorder write RESetBorder;
- { * |<#richedit>
- Border space. }
- property RE_BorderStyle[ Side: TBorderEdge ]: Integer index 4 read REGetBorder write RESetBorder;
- { * |<#richedit>
- Border style. }
- property RE_BorderValid: Boolean index PFM_BORDER read REGetParaAttrValid;
- { * |<#richedit>
- Returns True, if border style, space and width are the same for all
- paragraphs in selection. }
- property RE_Table: Boolean index $C000 read REGetParaEffect write RESetParaEffect;
- { * |<#richedit>
- True, if current paragraph is a part of table (row, cell or cell end).
- seems working as read only property. }
- // end of experiment section
-
- function RE_FmtStandard: PControl;
- {* |<#richedit>
- "Transparent" method (returns @Self as a result), which (when called)
- provides "standard" keyboard interface for formatting Rich text (just
- call this method, for example:
- ! RichEd1 := NewRichEdit( Panel1, [ ] ).SetAlign( caClient ).RE_FmtStandard;
- Following keys will be maintained additionally:
- |<pre>
- CTRL+I - switch "Italic",
- CTRL+B - switch "Bold",
- CTRL+U - switch "Underline",
- CTRL+SHIFT+U - swith underline type
- and turn underline on (note, that some of underline styles
- can not be shown properly in RichEdit v2.0 and lower,
- though RichEdit2.0 stores data successfully).
- CTRL+O - switch "StrikeOut",
- CTRL+'gray+' - increase font size,
- CTRL+'gray-' - decrease font size,
- CTRL+SHIFT+'gray+' - superscript,
- CTRL+SHIFT+'gray-' - subscript.
- CTRL+SHIFT+Z - ReDo
- |</pre>
- And, though following standard formatting keys are provided by RichEdit
- control itself in Windows2000, some of these are not functioning
- automatically in earlier Windows versions, even for RichEdit2.0. So,
- functionality of some of these (marked with (*) ) are added here too:
- |<pre>
- CTRL+L - align paragraph left, (*)
- CTRL+R - align paragraph right, (*)
- CTRL+E - align paragraph center, (*)
- CTRL+A - select all, (*)
- double-click on word - select word,
- CTRL+Right - to next word,
- CTRL+Left - to previous word,
- CTRL+Home - to the beginning of text,
- CTRL+End - to the end of text.
- CTRL+Z - UnDo
- |</pre>
- If You originally assign some (plain) text to Text property, switching "underline"
- can also change other font attributes, e.g., "bold" - if fsBold style is
- in default Font. To prevent such behavior, select entire text first (see
- SelectAll) and make assignment to RE_Font property, e.g.:
- ! RichEd1.SelectAll;
- ! RichEd1.RE_Font := RichEd1.RE_Font;
- ! RichEd1.SelLength := 0;
- |<br>
- And, some other notices about formatting. Please remember, that only True
- Type fonts can be succefully scaled and transformed to get desired effects
- (e.g., bold). By default, RichEdit uses System font face name, which can
- even have problems with fsBold style. Please remember also, that assigning
- RE_Font to RE_Font just initializying formatting attributes, making all
- those valid in entire text, but does not change font attributes. To use
- True Type font, directly assign face name You wish, e.g.:
- ! RichEd1.SelectAll;
- ! RichEd1.RE_Font := RichEd1.RE_Font;
- ! RichEd1.RE_Font.FontName := 'Arial';
- ! RichEd1.SelLength := 0;
- }
- procedure RE_CancelFmtStandard;
- {* Cancels RE_FmtStandard (detaching window procedure handler). }
- property RE_AutoKeyboard: Boolean index 1 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- True if autokeyboard on (lovely "feature" of automatic switching keyboard
- language when caret is over another language text). For older RichEdit,
- is 'on' always, for newest - 'off' by default. }
- property RE_AutoFont: Boolean index 2 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- True if autofont on (automatic switching font when keyboard layout is
- changes). By default, is 'on' always. It is suggested to turn this option
- off for Unicode control. }
- property RE_AutoFontSizeAdjust: Boolean index 16 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- See IMF_AUTOFONTSIZEADJUST option in SDK:
- Font-bound font sizes are scaled from insertion point size according to
- script. For example, Asian fonts are slightly larger than Western ones.
- This option is turned on by default. }
- property RE_DualFont: Boolean index 128 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- See IMF_DUALFONT option in SDK:
- Sets the control to dual-font mode. Used for Asian language support.
- The control uses an English font for ASCII text and a Asian font for
- Asian text. }
- property RE_UIFonts: Boolean index 32 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- See IMF_UIFONTS option in SDK:
- Use user-interface default fonts. This option is turned off by default. }
- property RE_IMECancelComplete: Boolean index 4 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- See IMF_IMECANCELCOMPLETE option in SDK:
- This flag determines how the control uses the composition string of an
- IME if the user cancels it. If this flag is set, the control discards
- the composition string. If this flag is not set, the control uses the
- composition string as the result string. }
- property RE_IMEAlwaysSendNotify: Boolean index 8 read REGetLangOptions write RESetLangOptions;
- {* |<#richedit>
- See IMF_IMEALWAYSSENDNOTIFY option in SDK:
- Controls how Rich Edit notifies the client during IME composition:
- |<br>
- 0: No EN_CHANGED or EN_SELCHANGE notifications during undetermined state.
- Send notification when final string comes in. (default)
- |<br>
- 1: Send EN_CHANGED and EN_SELCHANGE events during undetermined state. }
-
- property RE_OverwriteMode: Boolean read REGetOverwite write RESetOverwrite;
- {* |<#richedit>
- This property allows to control insert/overwrite mode. First, to examine, if
- insert or overwrite mode is current (but it is necessary either to
- access this property, at least once, immediately after creating RichEdit
- control, or to assign event OnRE_InsOvrMode_Change to your handler).
- Second, to set desired mode programmatically - by assigning value to
- this property (You also have to initialize monitoring procedure by either
- reading RE_OverwriteMode property or assigning handler to event
- OnRE_InsOvrMode_Change immediately following RichEdit control creation). }
- property OnRE_InsOvrMode_Change: TOnEvent read fOnREInsModeChg write fOnREInsModeChg;
- {* |<#richedit>
- This event is called, whenever key INSERT is pressed in control (and for
- RichEdit, this means, that insert mode is changed). }
- property RE_DisableOverwriteChange: Boolean read fReOvrDisable write RESetOvrDisable;
- {* |<#richedit>
- It is possible to disable switching between "insert" and "overwrite" mode
- by user (therefore, event OnRE_InsOvrMode_Change continue works, but it
- just called when key INSERT is pressed, though RE_OverwriteMode property
- is not actually changed if switching is disabled). }
-
- function RE_LoadFromStream( Stream: PStream; Length: Integer;
- Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
- {* |<#richedit>
- Use this method rather then assignment to RE_Text property, if
- source is stored in file or stream (to minimize resources during
- loading of RichEdit content). Data is loading starting from current
- position in stream and no more then Length bytes are loaded (use -1
- value to load to the end of stream). Loaded data replaces entire
- content of RichEdit control, or selection only, depending on SelectionOnly
- flag.
- |<br>
- If You want to provide progress (e.g. in form of progress bar), assign
- OnProgress event to your handler - and to examine current position of
- loading, read TSream.Position property of soiurce stream). }
- function RE_SaveToStream( Stream: PStream; Format: TRETextFormat; SelectionOnly: Boolean ): Boolean;
- {* |<#richedit>
- Use this method rather then RE_TextProperty to store data to file
- or stream (to minimize resources during saving of RichEdit content).
- Data is saving starting from current position in a stream (until
- end of RichEdit data). If SelectionOnly flag is True, only selected
- part of RichEdit text is saved.
- |<br>
- Like for RE_LoadFromStream, it is possible to assign your method to
- OnProgress event (but to calculate progress of save-to-stream operation,
- compare current stream position with RE_Size[ rsBytes ] property
- value). }
-
- property OnProgress: TOnEvent read fOnProgress write fOnProgress;
- {* |<#richedit>
- This event is called during RE_SaveToStream, RE_LoadFromStream (and also
- during RE_SaveToFile, RE_LoadFromFile and while accessing or changing
- RE_Text property). To calculate relative progress, it is possible to
- examine current position in stream/file with its total size while reading,
- or with rich edit text size, while writing (property RE_TextSize[ rsBytes ]).
- }
- function RE_LoadFromFile( const Filename: KOLString; Format: TRETextFormat;
- SelectionOnly: Boolean ): Boolean;
- {* |<#richedit>
- Use this method rather then other assignments to RE_Text property,
- if a source for RichEdit is the file. See also RE_LoadFromStream. }
- function RE_SaveToFile( const Filename: KOLString; Format: TRETextFormat;
- SelectionOnly: Boolean ): Boolean;
- {* |<#richedit>
- Use this method rather then other similar, if You want to store
- entire content of RichEdit or selection only of RichEdit to a file. }
-
- property RE_Text[ Format: TRETextFormat; SelectionOnly: Boolean ]: KOLString read REReadText write REWriteText;
- {* |<#richedit>
- This property allows to get / replace content of RichEdit control
- (entire text or selection only). Using different formats, it is
- possible to exclude or replace undesired formatting information
- (see TRETextFormat specification). To get or replace entire text
- in reText mode (plain text only), it is possible to use habitual
- for edit controls Text property.
- |<br>
- Note: it is possible to append text to the end of RichEdit control
- using method Add, but only if property RE_Text is accessed at least
- once:
- ! RichEdit1.RE_Text[ reText, True ];
- (This line can be written immediatelly after creating RichEdit control). }
-
- procedure RE_Append( const S: KOLString; ACanUndo: Boolean );
- {* }
- procedure RE_InsertRTF( const S: KOLString );
- {* }
- property RE_Error: Integer read fREError;
- {* |<#richedit>
- Contains error code, if access to RE_Text failed. }
-
- procedure RE_HideSelection( aHide: Boolean );
- {* |<#richedit>
- Allows to hide / show selection in RichEdit. }
-
- function RE_SearchText( const Value: KOLString; MatchCase, WholeWord, ScanForward: Boolean;
- SearchFrom, SearchTo: Integer ): Integer;
- {* |<#richedit>
- Searches given string starting from SearchFrom position up to SearchTo
- position (to the end of text, if SearchTo is -1). Returns zero-based
- character position of the next match, or -1 if there are no more matches.
- To search in bacward direction, set ScanForward to False, and pass
- SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
- {$IFNDEF DISABLE_DEPRECATED}
- {$IFNDEF _FPC}
- {$IFNDEF _D2} //------- WideString not supported in D2
- function RE_WSearchText( const Value: WideString; MatchCase, WholeWord, ScanForward: Boolean;
- SearchFrom, SearchTo: Integer ): Integer;
- {* |<#richedit>
- Searches given string starting from SearchFrom position up to SearchTo
- position (to the end of text, if SearchTo is -1). Returns zero-based
- character position of the next match, or -1 if there are no more matches.
- To search in bacward direction, set ScanForward to False, and pass
- SearchFrom > SearchTo (or even SearchFrom = -1 and SearchTo = 0). }
- {$ENDIF}
- {$ENDIF}
- {$ENDIF DISABLE_DEPRECATED}
-
- property RE_AutoURLDetect: Boolean read REGetAutoURLDetect write RESetAutoURLDetect;
- {* |<#richedit>
- If set to True, automatically detects URLs (and highlights it with
- blue color, applying fsItalic and fsUnderline font styles (while
- typing and loading). Default value is False. Note: if event OnRE_URLClick
- or event OnRE_OverURL are set, property RE_AutoURLDetect is set to True
- automatically. }
-
- property RE_URL: KOLString read fREUrl;
- {* |<#richedit>
- Detected URL (valid in OnRE_OverURL and OnRE_URLClick event handlers). }
- property OnRE_OverURL: TOnEvent index 0
- {$IFDEF F_P} read REGetOnURL
- {$ELSE DELPHI} read fOnREOverURL
- {$ENDIF F_P/DELPHI} write RESetOnURL;
- {* |<#richedit>
- Is called when mouse is moving over URL. This can be used to set
- cursor, for example, depending on type of URL (to determine URL type
- read property RE_URL). }
- property OnRE_URLClick: TOnEvent index 8
- {$IFDEF F_P} read REGetOnURL
- {$ELSE DELPHI} read fOnREURLClick
- {$ENDIF F_P/DELPHI} write RESetOnURL;
- {* |<#richedit>
- Is called when click on URL detected. }
-
- //property RE_SelectionBar: Boolean read REGetSelectionBar write RESetSelectionBar;
- //{* ??? - don't know that is this... }
- function RE_NoOLEDragDrop: PControl;
- {* |<#richedit>
- Just prevents drop OLE objects to the rich edit control. Seems not
- working for some cases. }
-
- //function RE_Wyswig: PControl;
-
- function RE_Bottomless: PControl;
- // finished ?
-
- property RE_Transparent: Boolean read REGetTransparent write RESetTransparent;
- {* |<#richedit>
- Use this property to make richedit control transparent, instead of
- Ed_Transparent or Transparent. But do not place such transparent
- richedit control directly on form - it can be draw incorrectly when
- form is activated and rich editr control is not current active control.
- Use at least panel as a parent instead.
- }
- property RE_Zoom: TSmallPoint read REGetZoom write RESetZoom;
- {* |<#richedit>
- To set zooming for rich edit control (3.0 and above), pass X as numerator
- and Y as denominator. Resulting X/Y must be between 1/64 and 64. }
- {$ENDIF NOT_USE_RICHEDIT}
-
- //========== both for Edit and RichEdit: =====================
- function CanUndo: Boolean;
- {* |<#richedit>
- |<#edit>
- |<#memo>
- Returns True, if the edit (or RichEdit) control can correctly process
- the EM_UNDO message. }
- procedure EmptyUndoBuffer;
- {* |<#richedit>
- |<#edit>
- |<#memo>
- Reset the undo flag of an edit control, preventing undoing all previous
- changes. }
- function Undo: Boolean;
- {* |<#richedit>
- |<#edit>
- |<#memo>
- For a single-line edit control, the return value is always TRUE. For a
- multiline edit control and RichEdit control, the return value is TRUE if
- the undo operation is successful, or FALSE if the undo operation fails. }
-
- {$IFNDEF NOT_USE_RICHEDIT}
- function RE_Redo: Boolean;
- {* |<#richedit>
- Only for RichEdit control: Returns True if successful. }
- {$ENDIF NOT_USE_RICHEDIT}
-
- //----------------------------------------------------------------------
- // DateTimePicker
- property OnDTPUserString: TDTParseInputEvent read FOnDTPUserString
- write FOnDTPUserString;
- {* Special event to parse input from the application. Option dtpoParseInput
- must be set when control is created. }
- property DateTime: TDateTime read GetDateTime write SetDateTime;
- {* DateTime for DateTimePicker control only. }
- property Date: TDateTime read GetDate write SetDate;
- {* Date only for DateTimePicker control only. }
- property Time: TDateTime read GetTime write SetTime;
- {* Time only for DateTimePicker control only. }
- property SystemTime: TSystemTime read Get_SystemTime write Set_SystemTime;
- {* Date and Time as TSystemTime. When assing, use year 0 to set "no value". }
- property DateTimeRange: TDateTimeRange read GetDateTimeRange
- write SetDateTimeRange;
- {* DateTimePicker range. If first date in the agrument assigned is NAN,
- minimum system allowed value is used as the left bound, and if the second is
- NAN, maximum system allowed is used as the right one. }
- property DateTimePickerColors[ Index: TDateTimePickerColor ]: TColor
- read GetDateTimePickerColor write SetDateTimePickerColor;
- property DateTimeFormat: KOLString write SetDateTimeFormat;
-
- //----------------------------------------------------------------------
-
- //----------------------------------------------------------------------
- // ScrollBar
- property SBMin: Longint read fSBMinMax.X write SetSBMin;
- {* }
- property SBMax: Longint read fSBMinMax.Y write SetSBMax;
- {* }
- property SBMinMax: TPoint read fSBMinMax write SetSBMinMax;
- {* }
- property SBPosition: Integer read fSBPosition write SetSBPosition;
- {* }
- property SBPageSize: Integer read fSBPageSize write SetSBPageSize;
- {* }
-
- property OnSBBeforeScroll: TOnSBBeforeScroll read FOnSBBeforeScroll write FOnSBBeforeScroll;
- {* }
- property OnSBScroll: TOnSBScroll read FOnSBScroll write FOnSBScroll;
- {* }
-
- function SBSetScrollInfo(const SI: TScrollInfo): Integer;
- function SBGetScrollInfo(var SI: TScrollInfo): Boolean;
- function GetSBMinMax: TPoint;
- function GetSBPageSize: Integer;
- function GetSBPosition: Integer;
- //----------------------------------------------------------------------
-
- // "Through", or "transparent" methods to simplify initial
- // adjustment of controls and make non-visual designing of
- // forms more easy. All these functions return @Self as a
- // result, so, it is possible to use such methods immediately
- // in constructing statement, concatenating it with dots, e.g.:
- //
- // NewButton( MyForm, 'Click here' ).PlaceUnder.ResizeParentBottom;
- //
- {$ENDIF GDI}
- function PlaceRight: PControl;
- {* Places control right (to previously created on the same parent). }
- function PlaceDown: PControl;
- {* Places control below (to previously created on the same parent).
- Left position is not changed (thus is, kept equal to Parent.Margin). }
- function PlaceUnder: PControl;
- {* Places control below (to previously created one, aligning its
- Left position to Left position of previous control). }
- function SetSize( W, H: Integer ): PControl;
- {* Changes size of a control. If W or H less or equal to 0,
- correspondent size is not changed. }
- {$IFDEF GDI}
- function Size( W, H: Integer ): PControl;
- {* Like SetSize, but provides automatic resizing of parent control
- (recursively). Especially useful for aligned controls. }
- function SetClientSize( W, H: Integer ): PControl;
- {* Like SetSize, but works setting W = ClientWidth, H = ClientHeight.
- Use this method for forms, which can not be resized (dialogs). }
-
- {$ENDIF GDI}
- function AutoSize( AutoSzOn: Boolean ): PControl;
- {$IFDEF GDI}
- function MakeWordWrap: PControl;
-
- {* Determines if to autosize control (like label, button, etc.) }
- function IsAutoSize: Boolean;
- {* TRUE, if a control is autosizing. }
- function AlignLeft( P: PControl ): PControl;
- {* assigns Left := P.Left }
- function AlignTop( P: PControl ): PControl;
- {* assigns Top := P.Top }
- function ResizeParent: PControl;
- {* Resizes parent, calling ResizeParentRight and ResizeParentBottom. }
- function ResizeParentRight: PControl;
- {* Resizes parent right edge (Margin of parent is added to right
- coordinate of a control). If called second time (for the same
- parent), resizes only for increasing of right edge of parent. }
-
- function ResizeParentBottom: PControl;
- {* Resizes parent bottom edge (Margin of parent is added to
- bottom coordinate of a control). }
- function CenterOnParent: PControl;
- {* Centers control on parent, or if applied to a form, centers
- form on screen. }
-
- function Shift( dX, dY : Integer ): PControl;
- {* Moves control respectively to current position (Left := Left + dX,
- Top := Top + dY). }
- {$ENDIF GDI}
- function SetPosition( X, Y: Integer ): PControl;
- {* Moves control directly to the specified position. }
- {$IFDEF GDI}
-
- function Tabulate: PControl;
- {* Call it once for form/applet to provide tabulation between controls on
- form/on all forms using TAB / SHIFT+TAB and arrow keys. }
- function TabulateEx: PControl;
- {* Call it once for form/applet to provide tabulation between controls on
- form/on all forms using TAB / SHIFT+TAB and arrow keys. Arrow keys are
- used more smart, allowing go to nearest control in certain direction. }
-
- function SetAlign( AAlign: TControlAlign ): PControl;
- {* Assigns passed value to property Align, aligning control on parent,
- and returns @Self (so it is "transparent" function, which can be
- used to adjust control at the creation, e.g.:
- ! MyLabel := NewLabel( MyForm, 'Label1' ).SetAlign( caBottom );
- See also property Align. }
- function PreventResizeFlicks: PControl;
- {* If called, prevents resizing flicks for child controls, aligned to
- right and bottom (but with a lot of code added to executable - about 3,5K).
- There is sensible to set DoubleBuffered to True also to eliminate the
- most of flicks.
- |<br>
- This method been applied to a form, prevents, resizing flicks for
- form and all controls on the form. If it is called for applet window,
- all forms are affected. And if You want, You can apply it for certain
- control only - in such case only given control and its children will
- be resizing without flicks (e.g., using splitter control). }
-
- property Checked: Boolean read GetChecked write Set_Checked;
- {* |<#checkbox>
- |<#radiobox>
- For checkbox and radiobox - if it is checked. Do not assign
- value for radiobox - use SetRadioChecked instead. }
- function SetChecked(const Value: Boolean): PControl;
- {* |<#checkbox>
- Use it to check/uncheck check box control or push button.
- Do not apply it to check radio buttons - use SetRadioChecked
- method below. }
- function SetRadioChecked : PControl;
- {* |<#radiobox>
- Use it to check radio button item correctly (unchecking all
- alternative ones). Actually, method Click is called, and control
- itself is returned. }
- function SetRadioCheckedOld: PControl;
- {* |<#radiobox>
- Old version of SetRadioChecked (implemented using recommended API
- call. It does not work properly, if control is not visible
- (together with its form). }
- property Check3: TTriStateCheck read GetCheck3 write SetCheck3;
- {* |<#checkbox>
- State of checkbox with BS_AUTO3STATE style. }
- procedure Click;
- {* |<#button>
- |<#checkbox>
- |<#radiobox>
- Emulates click on control programmatically, sending WM_COMMAND
- message with BN_CLICKED code. This method is sensible only for
- buttons, checkboxes and radioboxes. }
-
- function Perform( msgcode: DWORD; wParam, lParam: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Sends message to control's window (created if needed). }
- function Postmsg( msgcode: DWORD; wParam, lParam: Integer): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Sends message to control's window (created if needed). }
- procedure AttachProc( Proc: TWindowFunc );
- {* It is possible to attach dynamically any message handler to window
- procedure using this method. Last attached procedure is called first.
- If procedure returns True, further processing of a message is stopped.
- Attached procedure can be detached using DetachProc (but do not
- attach/detach procedures during handling of attached procedure -
- this can hang application). }
- procedure AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
- {* The same as AttachProc, but a handler is executed even after terminating
- the main message loop processing (i.e. after assigning true to
- AppletTerminated global variable. }
- function IsProcAttached( Proc: TWindowFunc ): Boolean;
- {* Returns True, if given procedure is already in chain of attached
- ones for given control window proc. }
- procedure DetachProc( Proc: TWindowFunc );
- {* Detaches procedure attached earlier using AttachProc. }
-
- property OnDropFiles: TOnDropFiles read FOnDropFiles write SetOnDropFiles;
- {* Assign this event to your handler, if You want to accept drag and drop
- files from other applications such as explorer onto your control. When
- this event is assigned to a control or form, this has effect also for
- all its child controls too. }
-
- property CustomData: Pointer read fCustomData write fCustomData;
- {* Can be used to exend the object when new type of control added. Memory,
- pointed by this pointer, released automatically in the destructor. }
- property CustomObj: PObj read fCustomObj write fCustomObj;
- {* Can be used to exend the object when new type of control added. Object,
- pointed by this pointer, released automatically in the destructor. }
- procedure SetAutoPopupMenu( PopupMenu: PObj );
- {* To assign a popup menu to the control, call SetAutoPopupMenu method of
- the control with popup menu object as a parameter. }
-
- function SupportMnemonics: PControl;
- {* This method provides supporting mnemonic keys in menus, buttons, checkboxes,
- toolbar buttons. }
- property OnScroll: TOnScroll read FOnScroll write SetOnScroll;
- {* }
- protected
- {$IFDEF USE_DROPDOWNCOUNT}
- fDropDownCount: Cardinal;
- {$ENDIF}
- fGraphCtlMouseEvent: TOnGraphCtlMouse;
- public
- {$IFDEF USE_DROPDOWNCOUNT}
- property DropDownCount: Cardinal read fDropDownCount write fDropDownCount;
- {$ENDIF}
- protected
- fPushedBtn: PControl;
- fFocused: Boolean;
- fEditOptions: TEditOptions;
- fEditCtl: PControl;
- fSetFocus: procedure of object;
- fSaveCursor: HCursor;
- fLeave: TOnEvent;
- fKeyboardProcess: TOnMessage;
- fHot: Boolean;
- fPressed : boolean;
- fHotCtl: PControl;
- fMouseLeaveProc: TOnEvent;
- fIsGroupBox: Boolean;
- fIsBitBtn: Boolean;
- fIsSplitter: Boolean;
- fErasingBkgnd: Boolean;
- fButtonIcon: HIcon;
- fActivating: Boolean;
- fFixingModal: Integer;
- {$IFDEF USE_GRAPHCTLS}
- function DoGraphCtlPrepaint: TRect;
- procedure GraphicLabelPaint( DC: HDC );
- procedure GraphicCheckBoxPaint( DC: HDC );
- procedure GraphicCheckBoxMouse( var Msg: TMsg );
- procedure GraphicRadioBoxPaint( DC: HDC );
- procedure GraphicButtonPaint( DC: HDC );
- procedure GraphicButtonMouse( var Msg: TMsg );
- procedure GraphButtonSetFocus;
- function GraphButtonKeyboardProcess( var Msg: TMsg; var Rslt: Integer ): Boolean;
- procedure LeaveGraphButton( Sender: PObj );
- procedure GraphicEditPaint( DC: HDC );
- procedure GraphicEditMouse( var Msg: TMsg );
- function EditGraphEdit: PControl;
- procedure DestroyGraphEdit( Sender: PObj );
- procedure LeaveGraphEdit( Sender: PObj );
- procedure ChangeGraphEdit( Sender: PObj );
- procedure GraphEditboxSetFocus;
- procedure GraphCtlDrawFocusRect( DC: HDC; const R: TRect );
- {$IFDEF GRAPHCTL_HOTTRACK}
- procedure MouseLeaveFromParentOfGraphCtl( Sender: PObj );
- {$ENDIF GRAPHCTL_HOTTRACK}
- procedure GroupBoxPaint( DC: HDC );
- {$ENDIF USE_GRAPHCTLS}
- {$IFDEF KEY_PREVIEW}
- protected
- fKeyPreview: Boolean;
- fKeyPreviewing: Boolean;
- fKeyPreviewCount: Integer;
- public
- property KeyPreview: Boolean read fKeyPreview write fKeyPreview;
- property KeyPreviewing: Boolean read fKeyPreviewing write fKeyPreviewing;
- {$ENDIF KEY_PREVIEW}
- protected
- fAnchorLeft: Boolean; //+Sormart
- fAnchorTop: Boolean; //+Sormart
- fAnchorRight: Boolean;
- fAnchorBottom: Boolean;
- fOldWidth, fOldHeight: Integer;
- procedure SetAnchorLeft(const Value: Boolean); //+Sormart
- procedure SetAnchorTop(const Value: Boolean); //+Sormart
- procedure SetAnchorRight( Value: Boolean );
- procedure SetAnchorBottom( Value: Boolean );
- public
- property AnchorLeft: Boolean read fAnchorLeft write SetAnchorLeft default true; //+Sormart
- property AnchorTop: Boolean read fAnchorTop write SetAnchorTop default true; //+Sormart
- property AnchorRight: Boolean read fAnchorRight write SetAnchorRight;
- property AnchorBottom: Boolean read fAnchorBottom write SetAnchorBottom;
- function Anchor( aLeft, aTop, aRight, aBottom: Boolean ): PControl;
- public
- {$IFDEF USE_CONSTRUCTORS}
- //------------------------------------------------------------
- // constructors here:
- constructor CreateWindowed( AParent: PControl; AClassName: PKOLChar; ACtl3D: Boolean );
- constructor CreateApplet( const ACaption: String );
- constructor CreateForm( AParent: PControl; const ACaption: String );
- constructor CreateControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;
- ACtl3D: Boolean; Actions: PCommandActions );
- constructor CreateButton( AParent: PControl; const ACaption: String );
- constructor CreateBitBtn( AParent: PControl; const ACaption: String;
- AOptions: TBitBtnOptions; ALayout: TGlyphLayout; AGlyphBitmap: HBitmap;
- AGlyphCount: Integer);
- constructor CreateLabel( AParent: PControl; const ACaption: String );
- constructor CreateWordWrapLabel( AParent: PControl; const ACaption: String );
- constructor CreateLabelEffect( AParent: PControl; ACaption: String; AShadowDeep: Integer );
- constructor CreatePaintBox( AParent: PControl );
- constructor CreateGradientPanel( AParent: PControl; AColor1, AColor2: TColor );
- constructor CreateGradientPanelEx( AParent: PControl; AColor1, AColor2: TColor;
- AStyle: TGradientStyle; ALayout: TGradientLayout );
- constructor CreateGroupbox( AParent: PControl; const ACaption: String );
- constructor CreateCheckbox( AParent: PControl; const ACaption: String );
- constructor CreateRadiobox( AParent: PControl; const ACaption: String );
- constructor CreateEditbox( AParent: PControl; AOptions: TEditOptions );
- constructor CreatePanel( AParent: PControl; AStyle: TEdgeStyle );
- constructor CreateSplitter( AParent: PControl; AMinSizePrev, AMinSizeNext: Integer;
- EdgeStyle: TEdgeStyle );
- constructor CreateListbox( AParent: PControl; AOptions: TListOptions );
- constructor CreateCombobox( AParent: PControl; AOptions: TComboOptions );
- constructor CreateCommonControl( AParent: PControl; AClassName: PChar; AStyle: DWORD;
- ACtl3D: Boolean; Actions: PCommandActions );
- constructor CreateRichEdit( AParent: PControl; AOptions: TEditOptions );
- constructor CreateRichEdit1( AParent: PControl; AOptions: TEditOptions );
- constructor CreateProgressbar( AParent: PControl );
- constructor CreateProgressbarEx( AParent: PControl; AOptions: TProgressbarOptions );
- constructor CreateListView( AParent: PControl; AStyle: TListViewStyle; AOptions: TListViewOptions;
- AImageListSmall, AImageListNormal, AImageListState: PImageList );
- constructor CreateTreeView( AParent: PControl; AOptions: TTreeViewOptions;
- AImgListNormal, AImgListState: PImageList );
- constructor CreateTabControl( AParent: PControl; ATabs: array of String;
- AOptions: TTabControlOptions; AImgList: PImageList; AImgList1stIdx: Integer );
- constructor CreateToolbar( AParent: PControl; AAlign: TControlAlign; AOptions: TToolbarOptions;
- ABitmap: HBitmap; AButtons: array of PChar;
- ABtnImgIdxArray: array of Integer );
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF USE_CUSTOMEXTENSIONS}
- {$I CUSTOM_TCONTROL_EXTENSION.inc}
- {$ENDIF}
- // If an option USE_CUSTOMEXTENSIONS is enabled (at the beginning of this
- // unit), You can freely extend TControl definition by your own fields,
- // methods and properties. This provides You with capability to extend
- // TControl implementing another kinds of visual controls without deriving
- // new descendant objects from TControl. This way is provided to avoid too
- // large grow of executable size. You also can derive your own controls
- // from TControl using standard OOP capabilities. In such case an option
- // USE_CONSTRUCTORS should be turned on (see it at the start of this unit).
- // If You choose this "flat" model of extending the TControl with your
- // own properties, fieds, methods, events, etc. You should provide three
- // inc-files: CUSTOM_TCONTROL_EXTENSION.inc, containing such definitions
- // for TControl, CUSTOM_KOL_EXTENSION.inc, containing needed global
- // declarations, and CUSTOM_CODE_EXTENSION.inc, the implementation of those
- // two.
- // Because KOL is always grow and constantly is extending by me, I also can
- // add my own complements for TControl. To avoid naming conflicts, I suggest
- // to use the same naming rule for all of You. Name your fields, properies, etc.
- // using a form idx_SomeName, where idx is a prefix, containing several
- // (at least one) letters and digits. E.g. ZK65_OnSomething.
-
- protected
- fParentCoordX: Integer;
- fParentCoordY: Integer;
- // last changes (1-Jul-06) from ECM [Michalichenko Eugeny, rest in peace, friend]:
- //======== ListBox
- private
- function GetLBTopIndex: Integer;
- procedure SetLBTopIndex(const Value: Integer);
- public
- function LBItemAtPos(X,Y: Integer): Integer;
- {* |<#listbox>
- Return index of item at the given position. }
- property LBTopIndex: Integer read GetLBTopIndex write SetLBTopIndex;
- {* |<#listbox>
- Index of the first visible item in a list box}
- //_________
- procedure MakeScrollable;
- {* Adds scrollbars to the control if its children do not fit client area. Useful for PocketPC dialog boxes. }
- {$ENDIF GDI}
- procedure DisableAlign;
- {* Disable alignment of child controls. }
- procedure EnableAlign;
- {* Enable alignment of child controls. }
- end;
- //[END OF TControl DEFINITION]
-
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE interface}
- {$I KOLMHToolTip.pas}
- {$UNDEF interface}
- {$ENDIF}
-
- {$IFDEF WIN_GDI}
- function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
- {* Use this function instead of reading TControl.TBButtonRect, if you want
- to have it working the same way when standard toolbar is used or GRushControl
- toolbar provided in ToGRush.pas unit.
- }
- procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer; const Tooltips: array of PKOLChar );
- {* Use this function instead of TContol.TBSetTooltips in your project, when
- you use ToGRush unit.
- }
- function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
- {* Use this function instead of reading the property TControl.TBButtonEnabled
- when tou use ToGRush unit. }
- procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
- {* Use this procedure instead of writing the property TControl.TBButtonEnabled
- when you use ToGRush unit. }
- function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
- {* Use this function instead of reading the property TControl.TBButtonVisible
- when tou use ToGRush unit. }
- procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
- {* Use this procedure instead of writing the property TControl.TBButtonVisible
- when you use ToGRush unit. }
- function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
- {* }
- procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
- {* }
- {$ENDIF WIN_GDI}
-
- var ToolbarsIDcmd: Integer = 100;
-
- //[Paint Background PROCEDURE]
- type
- TOnPaintBkgnd = procedure( Sender: PControl; DC: HDC; Rect: PRect );
- {* Global event definition. Used to define Global_OnPaintBackground
- event placeholder. }
-
- procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
-
- var
- Global_OnPaintBkgnd: TOnPaintBkgnd = DefaultPaintBackground;
- {* Global event. It is assigned in XBackgounds.pas add-on to replace
- PaintBackground method for all TVisual objects, allowing great
- visualization effect: transparent controls over [animated] bitmap
- background. Idea:
- | <a href=mailto:"bw@sunv.com">Wei Bao</a>. Implementation:
- | <a href=mailto:"bonanzas@xcl.cjb.net">Kladov Vladimir</a>. }
-
- procedure DummyPaintProc( Sender: PControl; DC: HDC );
-
- //[GetShiftState DECLARATION]
- function GetShiftState: DWORD;
- {* Returns shift state. }
-
- {$IFDEF WIN_GDI}
- //[WndProcXXX DECLARATIONS]
- function WndProcMouse( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- function WndProcKeybd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- function WndProcDummy( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- {$ENDIF}
- function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- {* By Sergey Shishmintzev.
- Attach this handler to your modal dialog form handle to provide automatic
- minimization of all other forms in the application together with the dialog. }
-
- //[InitCommonXXXX DECLARATIONS]
- procedure InitCommonControlSizeNotify( Ctrl: PControl );
- procedure InitCommonControlCommonNotify( Ctrl: PControl );
-
- //[Buffered Draw DECLARATIONS]
- procedure DummyAttachProcExtension ( DynHandlers: PList );
- {$ifdef win32}
- procedure TransparentAttachProcExtension ( DynHandlers: PList );
- {$endif win32}
-
- {$IFNDEF SMALLEST_CODE}
- var Global_AttachProcExtension: procedure( DynHandlers: PList ) = DummyAttachProcExtension;
- {$ENDIF}
- {$ENDIF WIN_GDI}
- var HelpFilePath: PChar;
- {* Path to application help file. If not assigned, application path with
- extension replaced to '.hlp' used. To use '.chm' file (HtmlHelp),
- call AssignHtmlHelp with a path to a html help file (or a name). }
-
- {$IFDEF WIN_GDI}
- //[Html Help DECLARATIONS]
- procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
- procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );
- {* Use this wrapper procedure to call HtmlHelp API function. }
- //+++++++++++ HTML HELP DEFINITIONS SECTION:
- // this section is from
- // HTML Help API Interface Unit
- // Copyright (c) 1999 The Helpware Group
- // provided for KOL by Alexey Babenko
- const
- HH_DISPLAY_TOPIC = $0000; {**}
- HH_HELP_FINDER = $0000; // WinHelp equivalent
- HH_DISPLAY_TOC = $0001; // not currently implemented
- HH_DISPLAY_INDEX = $0002; // not currently implemented
- HH_DISPLAY_SEARCH = $0003; // not currently implemented
- HH_SET_WIN_TYPE = $0004;
- HH_GET_WIN_TYPE = $0005;
- HH_GET_WIN_HANDLE = $0006;
- HH_ENUM_INFO_TYPE = $0007; // Get Info type name, call repeatedly to enumerate, -1 at end
- HH_SET_INFO_TYPE = $0008; // Add Info type to filter.
- HH_SYNC = $0009;
- HH_RESERVED1 = $000A;
- HH_RESERVED2 = $000B;
- HH_RESERVED3 = $000C;
- HH_KEYWORD_LOOKUP = $000D;
- HH_DISPLAY_TEXT_POPUP = $000E; // display string resource id or text in a popup window
- HH_HELP_CONTEXT = $000F; {**}// display mapped numeric value in dwData
- HH_TP_HELP_CONTEXTMENU = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU
- HH_TP_HELP_WM_HELP = $0011; // text popup help, same as WinHelp HELP_WM_HELP
- HH_CLOSE_ALL = $0012; // close all windows opened directly or indirectly by the caller
- HH_ALINK_LOOKUP = $0013; // ALink version of HH_KEYWORD_LOOKUP
- HH_GET_LAST_ERROR = $0014; // not currently implemented // See HHERROR.h
- HH_ENUM_CATEGORY = $0015; // Get category name, call repeatedly to enumerate, -1 at end
- HH_ENUM_CATEGORY_IT = $0016; // Get category info type members, call repeatedly to enumerate, -1 at end
- HH_RESET_IT_FILTER = $0017; // Clear the info type filter of all info types.
- HH_SET_INCLUSIVE_FILTER = $0018; // set inclusive filtering method for untyped topics to be included in display
- HH_SET_EXCLUSIVE_FILTER = $0019; // set exclusive filtering method for untyped topics to be excluded from display
- HH_INITIALIZE = $001C; // Initializes the help system.
- HH_UNINITIALIZE = $001D; // Uninitializes the help system.
- HH_PRETRANSLATEMESSAGE = $00fd; // Pumps messages. (NULL, NULL, MSG*).
- HH_SET_GLOBAL_PROPERTY = $00fc; // Set a global property. (NULL, NULL, HH_GPROP)
-
- { window properties }
-
- const
- HHWIN_PROP_TAB_AUTOHIDESHOW = $00000001; // (1 << 0) Automatically hide/show tri-pane window
- HHWIN_PROP_ONTOP = $00000002; // (1 << 1) Top-most window
- HHWIN_PROP_NOTITLEBAR = $00000004; // (1 << 2) no title bar
- HHWIN_PROP_NODEF_STYLES = $00000008; // (1 << 3) no default window styles (only HH_WINTYPE.dwStyles)
- HHWIN_PROP_NODEF_EXSTYLES = $00000010; // (1 << 4) no default extended window styles (only HH_WINTYPE.dwExStyles)
- HHWIN_PROP_TRI_PANE = $00000020; // (1 << 5) use a tri-pane window
- HHWIN_PROP_NOTB_TEXT = $00000040; // (1 << 6) no text on toolbar buttons
- HHWIN_PROP_POST_QUIT = $00000080; // (1 << 7) post WM_QUIT message when window closes
- HHWIN_PROP_AUTO_SYNC = $00000100; // (1 << 8) automatically ssync contents and index
- HHWIN_PROP_TRACKING = $00000200; // (1 << 9) send tracking notification messages
- HHWIN_PROP_TAB_SEARCH = $00000400; // (1 << 10) include search tab in navigation pane
- HHWIN_PROP_TAB_HISTORY = $00000800; // (1 << 11) include history tab in navigation pane
- HHWIN_PROP_TAB_FAVORITES = $00001000; // (1 << 12) include favorites tab in navigation pane
- HHWIN_PROP_CHANGE_TITLE = $00002000; // (1 << 13) Put current HTML title in title bar
- HHWIN_PROP_NAV_ONLY_WIN = $00004000; // (1 << 14) Only display the navigation window
- HHWIN_PROP_NO_TOOLBAR = $00008000; // (1 << 15) Don't display a toolbar
- HHWIN_PROP_MENU = $00010000; // (1 << 16) Menu
- HHWIN_PROP_TAB_ADVSEARCH = $00020000; // (1 << 17) Advanced FTS UI.
- HHWIN_PROP_USER_POS = $00040000; // (1 << 18) After initial creation, user controls window size/position
- HHWIN_PROP_TAB_CUSTOM1 = $00080000; // (1 << 19) Use custom tab #1
- HHWIN_PROP_TAB_CUSTOM2 = $00100000; // (1 << 20) Use custom tab #2
- HHWIN_PROP_TAB_CUSTOM3 = $00200000; // (1 << 21) Use custom tab #3
- HHWIN_PROP_TAB_CUSTOM4 = $00400000; // (1 << 22) Use custom tab #4
- HHWIN_PROP_TAB_CUSTOM5 = $00800000; // (1 << 23) Use custom tab #5
- HHWIN_PROP_TAB_CUSTOM6 = $01000000; // (1 << 24) Use custom tab #6
- HHWIN_PROP_TAB_CUSTOM7 = $02000000; // (1 << 25) Use custom tab #7
- HHWIN_PROP_TAB_CUSTOM8 = $04000000; // (1 << 26) Use custom tab #8
- HHWIN_PROP_TAB_CUSTOM9 = $08000000; // (1 << 27) Use custom tab #9
- HHWIN_TB_MARGIN = $10000000; // (1 << 28) the window type has a margin
-
- { window parameters }
-
- const
- HHWIN_PARAM_PROPERTIES = $00000002; // (1 << 1) valid fsWinProperties
- HHWIN_PARAM_STYLES = $00000004; // (1 << 2) valid dwStyles
- HHWIN_PARAM_EXSTYLES = $00000008; // (1 << 3) valid dwExStyles
- HHWIN_PARAM_RECT = $00000010; // (1 << 4) valid rcWindowPos
- HHWIN_PARAM_NAV_WIDTH = $00000020; // (1 << 5) valid iNavWidth
- HHWIN_PARAM_SHOWSTATE = $00000040; // (1 << 6) valid nShowState
- HHWIN_PARAM_INFOTYPES = $00000080; // (1 << 7) valid apInfoTypes
- HHWIN_PARAM_TB_FLAGS = $00000100; // (1 << 8) valid fsToolBarFlags
- HHWIN_PARAM_EXPANSION = $00000200; // (1 << 9) valid fNotExpanded
- HHWIN_PARAM_TABPOS = $00000400; // (1 << 10) valid tabpos
- HHWIN_PARAM_TABORDER = $00000800; // (1 << 11) valid taborder
- HHWIN_PARAM_HISTORY_COUNT = $00001000; // (1 << 12) valid cHistory
- HHWIN_PARAM_CUR_TAB = $00002000; // (1 << 13) valid curNavType
-
- { button constants }
-
- const
- HHWIN_BUTTON_EXPAND = $00000002; // (1 << 1) Expand/contract button
- HHWIN_BUTTON_BACK = $00000004; // (1 << 2) Back button
- HHWIN_BUTTON_FORWARD = $00000008; // (1 << 3) Forward button
- HHWIN_BUTTON_STOP = $00000010; // (1 << 4) Stop button
- HHWIN_BUTTON_REFRESH = $00000020; // (1 << 5) Refresh button
- HHWIN_BUTTON_HOME = $00000040; // (1 << 6) Home button
- HHWIN_BUTTON_BROWSE_FWD = $00000080; // (1 << 7) not implemented
- HHWIN_BUTTON_BROWSE_BCK = $00000100; // (1 << 8) not implemented
- HHWIN_BUTTON_NOTES = $00000200; // (1 << 9) not implemented
- HHWIN_BUTTON_CONTENTS = $00000400; // (1 << 10) not implemented
- HHWIN_BUTTON_SYNC = $00000800; // (1 << 11) Sync button
- HHWIN_BUTTON_OPTIONS = $00001000; // (1 << 12) Options button
- HHWIN_BUTTON_PRINT = $00002000; // (1 << 13) Print button
- HHWIN_BUTTON_INDEX = $00004000; // (1 << 14) not implemented
- HHWIN_BUTTON_SEARCH = $00008000; // (1 << 15) not implemented
- HHWIN_BUTTON_HISTORY = $00010000; // (1 << 16) not implemented
- HHWIN_BUTTON_FAVORITES = $00020000; // (1 << 17) not implemented
- HHWIN_BUTTON_JUMP1 = $00040000; // (1 << 18)
- HHWIN_BUTTON_JUMP2 = $00080000; // (1 << 19)
- HHWIN_BUTTON_ZOOM = $00100000; // (1 << 20)
- HHWIN_BUTTON_TOC_NEXT = $00200000; // (1 << 21)
- HHWIN_BUTTON_TOC_PREV = $00400000; // (1 << 22)
-
- HHWIN_DEF_BUTTONS = (HHWIN_BUTTON_EXPAND
- OR HHWIN_BUTTON_BACK
- OR HHWIN_BUTTON_OPTIONS
- OR HHWIN_BUTTON_PRINT);
-
- { Button IDs }
-
- const
- IDTB_EXPAND = 200;
- IDTB_CONTRACT = 201;
- IDTB_STOP = 202;
- IDTB_REFRESH = 203;
- IDTB_BACK = 204;
- IDTB_HOME = 205;
- IDTB_SYNC = 206;
- IDTB_PRINT = 207;
- IDTB_OPTIONS = 208;
- IDTB_FORWARD = 209;
- IDTB_NOTES = 210; // not implemented
- IDTB_BROWSE_FWD = 211;
- IDTB_BROWSE_BACK = 212;
- IDTB_CONTENTS = 213; // not implemented
- IDTB_INDEX = 214; // not implemented
- IDTB_SEARCH = 215; // not implemented
- IDTB_HISTORY = 216; // not implemented
- IDTB_FAVORITES = 217; // not implemented
- IDTB_JUMP1 = 218;
- IDTB_JUMP2 = 219;
- IDTB_CUSTOMIZE = 221;
- IDTB_ZOOM = 222;
- IDTB_TOC_NEXT = 223;
- IDTB_TOC_PREV = 224;
-
- { Notification codes }
-
- const
- HHN_FIRST = (0-860);
- HHN_LAST = (0-879);
-
- HHN_NAVCOMPLETE = (HHN_FIRST-0);
- HHN_TRACK = (HHN_FIRST-1);
- HHN_WINDOW_CREATE = (HHN_FIRST-2);
-
- type
- {*** Used by command HH_GET_LAST_ERROR
- NOTE: Not part of the htmlhelp.h but documented in HH Workshop help
- You must call SysFreeString(xx.description) to free BSTR
- }
- tagHH_LAST_ERROR = {$ifndef wince}packed{$endif} record
- cbStruct: Integer; // sizeof this structure
- hr: Integer; // Specifies the last error code.
- description: PWideChar; // (BSTR) Specifies a Unicode string containing a description of the error.
- end;
- HH_LAST_ERROR = tagHH_LAST_ERROR;
- THHLastError = tagHH_LAST_ERROR;
-
- type
- {*** Notify event info for HHN_NAVCOMPLETE, HHN_WINDOW_CREATE }
- PHHNNotify = ^THHNNotify;
- tagHHN_NOTIFY = {$ifndef wince}packed{$endif} record
- hdr: TNMHdr;
- pszUrl: PChar; //PCSTR: Multi-byte, null-terminated string
- end;
- HHN_NOTIFY = tagHHN_NOTIFY;
- THHNNotify = tagHHN_NOTIFY;
-
- {** Use by command HH_DISPLAY_TEXT_POPUP}
- PHHPopup = ^THHPopup;
- tagHH_POPUP = {$ifndef wince}packed{$endif} record
- cbStruct: Integer; // sizeof this structure
- hinst: HINST; // instance handle for string resource
- idString: cardinal; // string resource id, or text id if pszFile is specified in HtmlHelp call
- pszText: PChar; // used if idString is zero
- pt: TPOINT; // top center of popup window
- clrForeground: COLORREF; // use -1 for default
- clrBackground: COLORREF; // use -1 for default
- rcMargins: TRect; // amount of space between edges of window and text, -1 for each member to ignore
- pszFont: PChar; // facename, point size, char set, BOLD ITALIC UNDERLINE
- end;
- HH_POPUP = tagHH_POPUP;
- THHPopup = tagHH_POPUP;
-
- {** Use by commands - HH_ALINK_LOOKUP, HH_KEYWORD_LOOKUP}
- PHHAKLink = ^THHAKLink;
- tagHH_AKLINK = {$ifndef wince}packed{$endif} record
- cbStruct: integer; // sizeof this structure
- fReserved: BOOL; // must be FALSE (really!)
- pszKeywords: PChar; // semi-colon separated keywords
- pszUrl: PChar; // URL to jump to if no keywords found (may be NULL)
- pszMsgText: PChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
- pszMsgTitle: PChar; // Message text to display in MessageBox if pszUrl is NULL and no keyword match
- pszWindow: PChar; // Window to display URL in
- fIndexOnFail: BOOL; // Displays index if keyword lookup fails.
- end;
- HH_AKLINK = tagHH_AKLINK;
- THHAKLink = tagHH_AKLINK;
-
- const
- HHWIN_NAVTYPE_TOC = 0;
- HHWIN_NAVTYPE_INDEX = 1;
- HHWIN_NAVTYPE_SEARCH = 2;
- HHWIN_NAVTYPE_FAVORITES = 3;
- HHWIN_NAVTYPE_HISTORY = 4; // not implemented
- HHWIN_NAVTYPE_AUTHOR = 5;
- HHWIN_NAVTYPE_CUSTOM_FIRST = 11;
-
- const
- IT_INCLUSIVE = 0;
- IT_EXCLUSIVE = 1;
- IT_HIDDEN = 2;
-
- type
- PHHEnumIT = ^THHEnumIT;
- tagHH_ENUM_IT = {$ifndef wince}packed{$endif} record //tagHH_ENUM_IT, HH_ENUM_IT, *PHH_ENUM_IT
- cbStruct: Integer; // size of this structure
- iType: Integer; // the type of the information type ie. Inclusive, Exclusive, or Hidden
- pszCatName: PAnsiChar; // Set to the name of the Category to enumerate the info types in a category; else NULL
- pszITName: PAnsiChar; // volitile pointer to the name of the infotype. Allocated by call. Caller responsible for freeing
- pszITDescription: PAnsiChar; // volitile pointer to the description of the infotype.
- end;
- THHEnumIT = tagHH_ENUM_IT;
-
- type
- PHHEnumCat = ^THHEnumCat;
- tagHH_ENUM_CAT = {$ifndef wince}packed{$endif} record //tagHH_ENUM_CAT, HH_ENUM_CAT, *PHH_ENUM_CAT
- cbStruct: Integer; // size of this structure
- pszCatName: PAnsiChar; // volitile pointer to the category name
- pszCatDescription: PAnsiChar; // volitile pointer to the category description
- end;
- THHEnumCat = tagHH_ENUM_CAT;
-
- type
- PHHSetInfoType = ^THHSetInfoType;
- tagHH_SET_INFOTYPE = {$ifndef wince}packed{$endif} record //tagHH_SET_INFOTYPE, HH_SET_INFOTYPE, *PHH_SET_INFOTYPE
- cbStruct: Integer; // the size of this structure
- pszCatName: PAnsiChar; // the name of the category, if any, the InfoType is a member of.
- pszInfoTypeName: PAnsiChar; // the name of the info type to add to the filter
- end;
- THHSetInfoType = tagHH_SET_INFOTYPE;
-
- type
- HH_INFOTYPE = DWORD;
- THHInfoType = HH_INFOTYPE;
- PHHInfoType = ^THHInfoType; //PHH_INFOTYPE
-
- const
- HHWIN_NAVTAB_TOP = 0;
- HHWIN_NAVTAB_LEFT = 1;
- HHWIN_NAVTAB_BOTTOM = 2;
-
- const
- HH_MAX_TABS = 19; // maximum number of tabs
- const
- HH_TAB_CONTENTS = 0;
- HH_TAB_INDEX = 1;
- HH_TAB_SEARCH = 2;
- HH_TAB_FAVORITES = 3;
- HH_TAB_HISTORY = 4;
- HH_TAB_AUTHOR = 5;
- HH_TAB_CUSTOM_FIRST = 11;
- HH_TAB_CUSTOM_LAST = HH_MAX_TABS;
-
- HH_MAX_TABS_CUSTOM = (HH_TAB_CUSTOM_LAST - HH_TAB_CUSTOM_FIRST + 1);
-
- { HH_DISPLAY_SEARCH Command Related Structures and Constants }
-
- const
- HH_FTS_DEFAULT_PROXIMITY = (-1);
-
- type
- {** Used by command HH_DISPLAY_SEARCH}
- PHHFtsQuery = ^THHFtsQuery;
- tagHH_FTS_QUERY = {$ifndef wince}packed{$endif} record //tagHH_FTS_QUERY, HH_FTS_QUERY
- cbStruct: integer; // Sizeof structure in bytes.
- fUniCodeStrings: BOOL; // TRUE if all strings are unicode.
- pszSearchQuery: PChar; // String containing the search query.
- iProximity: LongInt; // Word proximity.
- fStemmedSearch: Bool; // TRUE for StemmedSearch only.
- fTitleOnly: Bool; // TRUE for Title search only.
- fExecute: Bool; // TRUE to initiate the search.
- pszWindow: PChar; // Window to display in
- end;
- THHFtsQuery = tagHH_FTS_QUERY;
-
- { HH_WINTYPE Structure }
-
- type
- {** Used by commands HH_GET_WIN_TYPE, HH_SET_WIN_TYPE}
- PHHWinType = ^THHWinType;
- tagHH_WINTYPE = {$ifndef wince}packed{$endif} record //tagHH_WINTYPE, HH_WINTYPE, *PHH_WINTYPE;
- cbStruct: Integer; // IN: size of this structure including all Information Types
- fUniCodeStrings: BOOL; // IN/OUT: TRUE if all strings are in UNICODE
- pszType: PChar; // IN/OUT: Name of a type of window
- fsValidMembers: DWORD; // IN: Bit flag of valid members (HHWIN_PARAM_)
- fsWinProperties: DWORD; // IN/OUT: Properties/attributes of the window (HHWIN_)
-
- pszCaption: PChar; // IN/OUT: Window title
- dwStyles: DWORD; // IN/OUT: Window styles
- dwExStyles: DWORD; // IN/OUT: Extended Window styles
- rcWindowPos: TRect; // IN: Starting position, OUT: current position
- nShowState: Integer; // IN: show state (e.g., SW_SHOW)
-
- hwndHelp: HWND; // OUT: window handle
- hwndCaller: HWND; // OUT: who called this window
-
- paInfoTypes: PHHInfoType; // IN: Pointer to an array of Information Types
-
- { The following members are only valid if HHWIN_PROP_TRI_PANE is set }
-
- hwndToolBar: HWND; // OUT: toolbar window in tri-pane window
- hwndNavigation: HWND; // OUT: navigation window in tri-pane window
- hwndHTML: HWND; // OUT: window displaying HTML in tri-pane window
- iNavWidth: Integer; // IN/OUT: width of navigation window
- rcHTML: TRect; // OUT: HTML window coordinates
-
- pszToc: PChar; // IN: Location of the table of contents file
- pszIndex: PChar; // IN: Location of the index file
- pszFile: PChar; // IN: Default location of the html file
- pszHome: PChar; // IN/OUT: html file to display when Home button is clicked
- fsToolBarFlags: DWORD; // IN: flags controling the appearance of the toolbar (HHWIN_BUTTON_)
- fNotExpanded: BOOL; // IN: TRUE/FALSE to contract or expand, OUT: current state
- curNavType: Integer; // IN/OUT: UI to display in the navigational pane
- tabpos: Integer; // IN/OUT: HHWIN_NAVTAB_TOP, HHWIN_NAVTAB_LEFT, or HHWIN_NAVTAB_BOTTOM
- idNotify: Integer; // IN: ID to use for WM_NOTIFY messages
- tabOrder: packed array[0..HH_MAX_TABS] of Byte; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs
- cHistory: Integer; // IN/OUT: number of history items to keep (default is 30)
- pszJump1: PChar; // Text for HHWIN_BUTTON_JUMP1
- pszJump2: PChar; // Text for HHWIN_BUTTON_JUMP2
- pszUrlJump1: PChar; // URL for HHWIN_BUTTON_JUMP1
- pszUrlJump2: PChar; // URL for HHWIN_BUTTON_JUMP2
- rcMinSize: TRect; // Minimum size for window (ignored in version 1)
-
- cbInfoTypes: Integer; // size of paInfoTypes;
- pszCustomTabs: PChar; // multiple zero-terminated strings
- end;
- HH_WINTYPE = tagHH_WINTYPE;
- THHWinType = tagHH_WINTYPE;
-
- const
- HHACT_TAB_CONTENTS = 0;
- HHACT_TAB_INDEX = 1;
- HHACT_TAB_SEARCH = 2;
- HHACT_TAB_HISTORY = 3;
- HHACT_TAB_FAVORITES = 4;
-
- HHACT_EXPAND = 5;
- HHACT_CONTRACT = 6;
- HHACT_BACK = 7;
- HHACT_FORWARD = 8;
- HHACT_STOP = 9;
- HHACT_REFRESH = 10;
- HHACT_HOME = 11;
- HHACT_SYNC = 12;
- HHACT_OPTIONS = 13;
- HHACT_PRINT = 14;
- HHACT_HIGHLIGHT = 15;
- HHACT_CUSTOMIZE = 16;
- HHACT_JUMP1 = 17;
- HHACT_JUMP2 = 18;
- HHACT_ZOOM = 19;
- HHACT_TOC_NEXT = 20;
- HHACT_TOC_PREV = 21;
- HHACT_NOTES = 22;
-
- HHACT_LAST_ENUM = 23;
-
- type
- {*** Notify event info for HHN_TRACK }
- PHHNTrack = ^THHNTrack;
- tagHHNTRACK = {$ifndef wince}packed{$endif} record //tagHHNTRACK, HHNTRACK;
- hdr: TNMHdr;
- pszCurUrl: PChar; // Multi-byte, null-terminated string
- idAction: Integer; // HHACT_ value
- phhWinType: PHHWinType; // Current window type structure
- end;
- HHNTRACK = tagHHNTRACK;
- THHNTrack = tagHHNTRACK;
-
- ///////////////////////////////////////////////////////////////////////////////
- //
- // Global Control Properties.
- //
- const
- HH_GPROPID_SINGLETHREAD = 1; // VARIANT_BOOL: True for single thread
- HH_GPROPID_TOOLBAR_MARGIN = 2; // long: Provides a left/right margin around the toolbar.
- HH_GPROPID_UI_LANGUAGE = 3; // long: LangId of the UI.
- HH_GPROPID_CURRENT_SUBSET = 4; // BSTR: Current subset.
- HH_GPROPID_CONTENT_LANGUAGE = 5; // long: LandId for desired content.
-
- type
- tagHH_GPROPID = HH_GPROPID_SINGLETHREAD..HH_GPROPID_CONTENT_LANGUAGE; //tagHH_GPROPID, HH_GPROPID
- HH_GPROPID = tagHH_GPROPID;
- THHGPropID = HH_GPROPID;
-
- ///////////////////////////////////////////////////////////////////////////////
- //
- // Global Property structure
- //
- {type
- PHHGlobalProperty = ^THHGlobalProperty;
- tagHH_GLOBAL_PROPERTY = record //tagHH_GLOBAL_PROPERTY, HH_GLOBAL_PROPERTY
- id: THHGPropID;
- Dummy: Integer; // Added to enforce 8-byte packing
- var_: VARIANT;
- end;
- HH_GLOBAL_PROPERTY = tagHH_GLOBAL_PROPERTY;
- THHGlobalProperty = tagHH_GLOBAL_PROPERTY;}
- //[END OF HTMLHELP DECLARATIONS]
- {$ENDIF WIN_GDI}
-
- {$IFDEF WIN_GDI}
- //[GetCtlBrush DECLARATIONS]
- function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
-
- var
- Global_GetCtlBrushHandle: function( Sender: PControl ): HBrush = SimpleGetCtlBrushHandle;
- {* Is called to obtain brush handle. }
- {$ENDIF WIN_GDI}
-
- Global_Align: procedure( Sender: PObj ) = DummyObjProc;
- {* Is set to perform aligning of control, and only if property Align
- is changed for TControl, or SetAlign method is called for it. }
-
- {$IFDEF WIN_GDI}
- //[WndFunc DECLARATION]
- function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
- : Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Global message handler for window. Redirects all messages to
- destination windows, obtaining target TControl object address from
- window itself, using GetProp API call. }
- {$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- //[Applet VARIABLES]
- var AppletRunning: Boolean;
- {* Is set to True while message loop is processing (in Run procedure). }
- AppletTerminated: Boolean;
- {* Is set to True when message loop is terminated. }
- Applet: PControl;
- {* Applet window object. Actually, can be set to main form if program
- not needed in special applet button window (useful to make applet
- button invisible on taskbar, or to have several forms with single
- applet button - crete it in that case using NewApplet). }
- AppButtonUsed: Boolean;
- {* True if special window to represent applet button (may be invisible)
- is used. If no, every form is represented with its own taskbar button
- (always visible). }
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[Screen DECLARATIONS]
- ScreenCursor: HCursor;
- {* Set this global variable to override any cursor settings of current
- form or control. }
-
- function ScreenWidth: Integer;
- {* Returns screen width in pixels. }
- function ScreenHeight: Integer;
- {* Returns screen height in pixels. }
-
- //[Status DECLARATIONS]
- type
- TStatusOption = ( soNoSizeGrip, soTop );
- {* Options available for status bars. }
- TStatusOptions = Set of TStatusOption;
- {* Status bar options. }
-
- procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
- {* This procedure can be useful to draw control's text in custom-defined controls. }
-
- {$IFDEF USE_GRAPHCTLS}
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- var DoNotDrawGraphCtlsUsingXPStyles: Boolean;
- procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
- var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
- {* This procedure can be useful to draw control's text in custom-defined controls. }
- {$ENDIF}
-
- function _NewGraphCtl( AParent: PControl; ATabStop: Boolean ): PControl;
- {* Creates graphic control basics. }
-
- function NewGraphLabel( AParent: PControl; const ACaption: String ): PControl;
- {* Creates graphic label, which does not require a window handle. }
-
- function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
- {* Creates graphic label, which does not require a window handle. }
-
- function NewGraphPaintBox( AParent: PControl ): PControl;
- {* Creates graphic paint box (just the same as graphic label, but with empty Caption). }
-
- function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
- {* Creates graphic checkbox. }
-
- function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
- {* Creates graphic radiobox. }
-
- function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
- {* Creates graphic button. }
-
- function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
- {* Creates graphic edit box. To do editing, this box should be replaced with
- real edit box with a handle (actually, it is enough to place an edit box
- on the same Parent having the same BoundsRect). }
- {$ENDIF USE_GRAPHCTLS}
- {$ENDIF WIN_GDI}
-
- //[Run DECLARATION]
- procedure Run( var AppletWnd: PControl );
- {* |<#appbutton>
- Call this procedure to process messages loop of your program.
- Pass here pointer to applet button object (if You have created it
- - see NewApplet) or your main form object of type PControl (created
- using NewForm).
- |<br><br>
- |<h1 align=center><font color=#FF8040><a name="visual_objects_constructors"></a>
- Visual objects constructing functions
- |</font></h1>
- Following constructing functions for visual controls are available:
- |#control
- }
-
- {$IFDEF WIN_GDI}
-
- procedure TerminateExecution( var AppletWnd: PControl );
-
- //[Applet FUNCTIONS DECLARATIONS]
- procedure AppletMinimize;
- {* Minimizes the application (Applet should be assigned to have effect). }
- procedure AppletHide;
- {* Minimizes and hides application. }
- procedure AppletRestore;
- {* Restores Applet when minimized. }
-
- {$IFDEF USE_OnIdle}
- //[Idle handler DECALRATIONS]
- {YS+}
- procedure RegisterIdleHandler( const OnIdle: TOnEvent );
- {* Registers new Idle handler. Idle handler is called each time when
- message queue becomes empty. }
- procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
- {* Unregisters Idle handler. }
- {YS-}
- {$ENDIF USE_OnIdle}
-
- //[InitCommonXXXX ANOTHER DECLARATIONS]
-
- {* ComCtrl32 controls initialization. }
- {$ifdef win32}
- procedure InitCommonControls; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$endif win32}
- procedure DoInitCommonControls( dwICC: DWORD );
- {* Calls extended initialization for Common Controls (from ComCtrl32).
- Pass one of following constants:
- |<pre>
- ICC_LISTVIEW_CLASSES = $00000001; // listview, header
- ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
- ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
- ICC_TAB_CLASSES = $00000008; // tab, tooltips
- ICC_UPDOWN_CLASS = $00000010; // updown
- ICC_PROGRESS_CLASS = $00000020; // progress
- ICC_HOTKEY_CLASS = $00000040; // hotkey
- ICC_ANIMATE_CLASS = $00000080; // animate
- ICC_WIN95_CLASSES = $000000FF;
- ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
- ICC_USEREX_CLASSES = $00000200; // comboex
- ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
- ICC_INTERNET_CLASSES = $00000800;
- ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
- ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
- |</pre>
- }
-
- const
- ICC_LISTVIEW_CLASSES = $00000001; // listview, header
- ICC_TREEVIEW_CLASSES = $00000002; // treeview, tooltips
- ICC_BAR_CLASSES = $00000004; // toolbar, statusbar, trackbar, tooltips
- ICC_TAB_CLASSES = $00000008; // tab, tooltips
- ICC_UPDOWN_CLASS = $00000010; // updown
- ICC_PROGRESS_CLASS = $00000020; // progress
- ICC_HOTKEY_CLASS = $00000040; // hotkey
- ICC_ANIMATE_CLASS = $00000080; // animate
- ICC_WIN95_CLASSES = $000000FF;
- ICC_DATE_CLASSES = $00000100; // month picker, date picker, time picker, updown
- ICC_USEREX_CLASSES = $00000200; // comboex
- ICC_COOL_CLASSES = $00000400; // rebar (coolbar) control
- ICC_INTERNET_CLASSES = $00000800;
- ICC_PAGESCROLLER_CLASS = $00001000; // page scroller
- ICC_NATIVEFNTCTL_CLASS = $00002000; // native font control
-
- {$ifdef win32}
- //[Ole DECLARATIONS]
- function OleInit: Boolean;
- {* Calls OleInitialize (once - all other calls are simulated by incrementing
- call counter. Every OleInit shoud be complemented with correspondent OleUninit.
- (Though, it is possible to call API function OleUnInitialize once to
- cancel all OleInit calls). }
- procedure OleUnInit;
- {* Decrements counter and calls OleUnInitialize when it is zeroed. }
- var OleInitCount: Integer;
- {-}
-
- function StringToOleStr(const Source: string): PWideChar;
- {* }
-
- {+}
- function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; {$ifdef wince}cdecl{$else}stdcall{$endif};
- procedure SysFreeString( psz: PWideChar ); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$endif win32}
- {$ENDIF WIN_GDI}
- { -- Contructors for visual controls -- }
- //[NewXXXX DECLARATIONS]
-
- //[_NewWindowed DECLARATION]
- {$IFDEF GDI}
- function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean ): PControl;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function _NewWindowed( AParent: PControl; ControlClassName: PChar;
- widget: PGtkWidget; need_eventbox: Boolean ): PControl;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[NewApplet DECLARATION]
- function NewApplet( const Caption: KOLString ): PControl;
- {* |<#control>
- Creates applet button window, which has to be parent of all other forms
- in your project (but this is *not must*). See also comments about NewForm.
- |<br>
- Following methods, properties and events are useful to work with applet
- control:
- |#appbutton }
-
- {$ENDIF WIN_GDI}
- //[NewForm DECLARATION]
- function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates form window object and returns pointer to it. If You use only one form,
- and You are not going to do applet button on task bar invisible, it is not
- necessary to create also special applet button window - just pass
- your (main) form object to Run procedure. In that case, it is a good
- idea to assign pointer to your main form object to Applet variable
- immediately following creating it - because some objects (e.g. TTimer)
- want to have Applet assigned to something.
- |<br>
- |&D=<a href="tcontrol.htm#%1" target=_top> %0 </a>
- Following methods, properties and events are useful to work with forms
- (ones common for all visual objects, such as <D Left>, <D Top>, <D Width>,
- <D Height>, etc. are not listed here - look TControl for it):
- |#form }
-
- //[_NewControl DECLARATION]
- {$IFDEF GDI}
- function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
- Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function _NewControl( AParent: PControl; ControlClassName: PChar;
- Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[NewButton DECLARATION]
- function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates button on given parent control or form.
- Please note, that in Windows, buttons can not change its <D Font> color
- and to be <D Transparent>.
- |<br> Following methods, properies and events are (especially) useful with
- a button:
- |#button }
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[NewBitBtn DECLARATION]
- function NewBitBtn( AParent: PControl; const Caption: KOLString;
- Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap; GlyphCount: Integer ): PControl;
- {* |<#control>
- Creates image button (actually implemented as owner-drawn). In Options,
- it is possible to determine, whether bitmap or image list used to contain
- one or more (up to 5) images, correspondent to certain BitBtn state.
- |<br>
- For case of imagelist (option bboImageList), it is possible to use a
- number of glyphs from the image list, starting from image index given
- by GlyphCount parameter. Number of used glyphs is passed in that case
- in high word of GlyphCount parameter (if 0, one image is used therefore).
- For bboImageList, BitBtn can be Transparent (and in that case bboNoBorder
- style can be useful to draw custom buttons of non-rectangular shape).
- |<br>
- For case of bitmap BitBtn, image is stretched down (if too big), but can
- not be transparent. It is not necessary for bitmap BitBtn to pass correct
- GlyphCount - it is calculated on base of bitmap size, if 0 is passed.
- |<br>
- And, certainly, BitBtn can be without glyph image (text only). For that
- case, it is therefore is more flexible and power than usual Button (but
- requires more code). E.g., BitBtn can change its <D Font>, <D Color>,
- and to be totally <D Transparent>.
- Moreover, BitBtn can be <D Flat>, bboFixed, <D SpeedButton> and
- have property <D RepeatInterval>.
- |<br>
- Note: if You use bboFixed Style, use OnChange event instead of OnClick,
- because <D Checked> state is changed immediately however OnClick occure
- only when mouse or space key released (and can be not called at all if
- mouse button is released out of BitBtn bounds). Also, bboFixed defines
- only which glyph to show (the border if it is not turned off behaves as
- usual for a button, i.e. it becomes lowered and then raised again at any click).
- Here You can find references to other properties, events and methods
- applicable to BitBtn:
- |#bitbtn }
-
- {$ENDIF GDI}
- //[NewLabel DECLARATION]
- function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates static text control (native Windows STATIC control).
- Use property <D Caption> at run time to change label text. Also
- it is possible to adjust label <D Font>, <D Brush> or <D Color>.
- Label can be <D Transparent>. If You want to have rotated text
- label, call NewLabelEffect instead and change its <D Font>.FontOrientation.
- Other references certain for a label:
- |#label }
- {$IFDEF GDI}
-
- //[NewWordWrapLabel DECLARATION]
- function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates multiline static text control (native Windows STATIC control),
- which can wrap long text onto several lines. See also NewLabel.
- See also:
- |#wwlabel
- |#label }
-
- //[NewLabelEffect DECLARATION]
- function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
- {* |<#control>
- Creates 3D-label with capability to rotate its text <D Caption>, which
- is controlled by changing <D Font>.FontOrientation property. If You want
- to get flat effect label (e.g. to rotate it only), pass <D ShadowDeep> = 0.
- Please note, that drawing procedure uses <D Canvas> property, so using of
- LabelEffect leads to increase size of executable.
- See also:
- |#3dlabel
- |#label }
-
- {$ENDIF GDI}
- //[NewPaintbox DECLARATION]
- function NewPaintbox( AParent: PControl ): PControl;
- {* |<#control>
- Creates owner-drawn STATIC control. Set its <D OnPaint> event to
- perform custom painting.
- |#paintbox }
- {$IFDEF GDI}
-
- //[NewImageShow DECLARATION]
- function NewImageShow( AParent: PControl; AImgList: PImageList; ImgIdx: Integer ): PControl;
- {* |<#control>
- Creates an image show control, implemented as a paintbox which is used to
- draw an image from the imagelist. At run-time, use property CurIndex to
- select another image from the imagelist, and a property ImageListNormal to
- use another image list. When the control is created, its size becomes
- equal to dimensions of imagelist (if any). }
-
- //[NewScrollBar DECLARATION]
- function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
- {* |<#control>
- Creates simple scroll bar. }
-
- //[NewScrollBox DECLARATION]
- function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
- Bars: TScrollerBars ): PControl;
- {* |<#control>
- Creates simple scrolling box, which can be used any way you wish, e.g. to scroll
- certain large image. To provide automatic scrolling of a set of child controls,
- use advanced scroll box, created with NewScrollBoxEx. }
-
- procedure NotifyScrollBox( Self_, Child: PControl );
-
- function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
- {* |<#control>
- Creates extended scrolling box control, which automatically scrolls child
- controls (if any). }
-
- //[NewGradientPanel DECLARATION]
- function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
- {* |<#control>
- Creates gradient-filled STATIC control. To adjust colors at the
- run time, change <D Color1> and <D Color2> properties (which initially are
- assigned from Color1, Color2 parameters), and call <D Invalidate> method
- to repaint control. }
-
- function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
- Style: TGradientStyle; Layout: TGradientLayout ): PControl;
- {* |<#control>
- Creates gradient-filled STATIC control. To adjust colors at the
- run time, change <D Color1> and <D Color2> properties (which initially are
- assigned from Color1, Color2 parameters), and call <D Invalidate> method
- to repaint control. Depending on style and first line/point layout, can
- looking different. Idea: Vladimir Stojiljkovic. }
-
- //[NewPanel DECLARATION]
- function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
- {* |<#control>
- Creates panel, which can be parent for other controls (though, any
- control can be used as a parent for other ones, but panel is specially
- designed for such purpose). }
- {$ifdef win32}
- //[NewMDIxxx DECLARATIONS]
- function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
- {* |<#control>
- Creates MDI client window, which is a special type of child window,
- containing all MDI child windows, created calling NewMDIChild function.
- On a form, MDI client behaves like a panel, so it can be placed and sized
- (or aligned) like any other controls. To minimize flick during resizing
- main form having another aligned controls, place MDI client window on
- a panel and align it caClient in the panel.
- |<br>Note:
- MDI client must be a single on the form. }
-
- function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;
- {* |<#control>
- Creates MDI client window. AParent should be a MDI client window,
- created with NewMDIClient function. }
- {$endif win32}
- //[NewSplitter DECLARATIONS]
- function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
- {* |<#control>
- Creates splitter control, which will separate previous one (i.e. last
- created one before splitter on the same parent) from created
- next, allowing to user to adjust size of separated controls by dragging
- the splitter in desired direction. Created splitter becomes vertical
- or horizontal depending on Align style of previous control on the same
- parent (if caLeft/caRight then vertical, if caTop/caBottom then horizontal).
- |<br>
- Please note, what if previous control has no Align equal to caLeft/caRight
- or caTop/caBottom, splitter will not be able to function normally. If
- previous control does not exist, it is yet possible to use splitter as
- a resizeable panel (but set its initial Align value first - otherwise it
- is not set by default. Also, change Cursor property as You wish in that
- case, since it is not set too in case, when previous control does not
- exist).
- |<br>
- Additional parameters determine, which minimal size (width or height -
- correspondently to split direction) is allowed for left (top) control
- and to rest of client area of parent, correspondently. (It is possible
- later to set second control for checking its size with MinSizeNext
- value - using TControl.SecondControl property). If -1 passed,
- correspondent control size is not checked during dragging of splitter.
- Usually 0 is more suitable value (with this value, it is garantee, that
- splitter will be always available even if mouse was released far from the
- edge of form).
- |<br>
- It is possible for user to press Escape any time while dragging splitter
- to abort all adjustments made starting from left mouse button push and
- begin of drag the splitter. But remember please, that such event is
- controlled using timer, and therefore correspondent keyboard events
- are received by currently focused control. Be sure, that pressing Escape
- will not affect to any control on form, which could be focused, otherwise
- filter keyboard messages (by yourself) to prevent undesired handling of
- Escape key by certain controls while splitting. (Use Dragging property
- to check if splitter is dragging by user with mouse).
- |<br>
- See also:
- NewSplitterEx
- |#splitter }
-
- function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
- EdgeStyle: TEdgeStyle ): PControl;
- {* |<#control>
- Creates splitter control. Difference from NewSplitter is what it is possible
- to determine if a splitter will be beveled or not. See also NewSplitter. }
-
- //[NewGroupbox DECLARATION]
- function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates group box control. Note, that to group radio items, group
- box is not necessary - any parent can play role of group for radio items.
- See also NewPanel. }
-
- //[NewCheckbox DECLARATION]
- function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates check box control. Special properties, methods, events:
- |#checkbox }
-
- function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates check box control with 3 states. Special properties, methods,
- events:
- |#checkbox }
-
- //[NewRadiobox DECLARATION]
- function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
- {* |<#control>
- Creates radio box control. Alternative radio items must have the
- same parent window (regardless of its kind, either groupbox (NewGroupbox),
- panel (NewPanel) or form itself). Following properties, methods and events
- are specially for radiobox controls:
- |#radiobox }
-
- //[NewEditbox DECLARATION]
- function NewEditbox( AParent: PControl; Options: TEditOptions ): PControl;
- {* |<#control>
- Creates edit box control. To create multiline edit box, similar to
- TMemo in VCL, apply eoMultiline in Options. Following properties, methods,
- events are special for edit controls:
- |#edit }
-
- {$IFNDEF NOT_USE_RICHEDIT}
- var FRichEditModule: Integer;
- RichEditClass: PKOLChar;
-
- const RichEditLibnames: array[ 0..3 ] of PKOLChar =
- ( 'msftedit', 'riched20',
- 'riched32', 'riched' );
- RichEditClasses: array[ 0..3 ] of PKOLChar =
- ( 'RichEdit50W', 'RichEdit20A',
- 'RichEdit', 'RichEdit' );
- var RichEditIdx: Byte = High( RichEditLibnames );
-
- //[NewRichEdit DECLARATION]
- function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
- {* |<#control>
- Creates rich text edit control. A rich edit control is a window in which
- the user can enter and edit text. The text can be assigned character and
- paragraph formatting, and can include embedded OLE objects. Rich edit
- controls provide a programming interface for formatting text. However, an
- application must implement any user interface components necessary to make
- formatting operations available to the user.
- |<br>
- Note: eoPassword, eoMultiline options have no effect for RichEdit control.
- Some operations are supersided with special versions of those, created
- especially for RichEdit, but in some cases it is necessary to use
- another properties and methods, specially designed for RichEdit (see
- methods and properties, which names are starting from RE_...).
- |<br>
- Following properties, methods, events are special for edit controls:
- |#richedit
- }
-
- function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
- {* |<#control>
- Like NewRichEdit, but to work with older RichEdit control version 1.0
- (window class 'RichEdit' forced to use instead of 'RichEdit20A', even
- if library RICHED20.DLL found and loaded successfully). One more
- difference - OleInit is not called, so the most of OLE capabilities
- of RichEdit could not working. }
- {$ENDIF NOT_USE_RICHEDIT}
-
- //[NewListbox DECLARATION]
- function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
- {* |<#control>
- Creates list box control. Following properties, methods and events are
- special for Listbox:
- |#listbox }
-
- //[NewCombobox DECLARATION]
- function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
- {* |<#control>
- Creates new combo box control. Note, that it is not possible to align
- combobox caLeft or caRight: this can cause infinite recursion in the
- application.
- |<br>Following properties, methods and events are
- special for Combobox:
- |#combo }
-
- //[_NewCommonControl DECLARATION]
- function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
- Ctl3D: Boolean; Actions: PCommandActions ): PControl;
-
- //[NewProgressbar DECLARATION]
- function NewProgressbar( AParent: PControl ): PControl;
- {* |<#control>
- Creates progress bar control. Following properties are special for
- progress bar:
- |#progressbar
- See also NewProgressEx. }
-
- function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
- {* |<#control>
- Can create progress bar with smooth style (progress is not segmented
- onto bricks) or/and vertical progress bar - using additional parameter.
- For list of properties, suitable for progress bars, see NewProgressbar. }
-
- //[NewListVew DECLARATION]
- function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
- ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
- {* |<#control>
- Creates list view control. It is very powerful control, which can partially
- compensate absence of grid controls (in lvsDetail view mode). Properties,
- methods and events, special for list view control are:
- |#listview }
-
- //[NewTreeView DECLARATION]
- function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
- ImgListNormal, ImgListState: PImageList ): PControl;
- {* |<#control>
- Creates tree view control. See tree view methods and properties:
- |#treeview }
-
- //[NewTabControl DECLARATION]
- function NewTabControl( AParent: PControl; const Tabs: array of KOLString; Options: TTabControlOptions;
- ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
- {* |<#control>
- Creates new tab control (like notebook). To place child control on a certain
- page of TabControl, use property Pages[ Idx ], for example:
- ! Label1 := NewLabel( TabControl1.Pages[ 0 ], 'Label1' );
- |
- To determine number of pages at run time, use property <D Count>;
- |<br> to determine which page is currently selected (or to change
- selection), use property <D CurIndex>;
- |<br> to feedback to switch between tabs assign your handler to OnSelChange
- event;
- |<br>Note, that by default, tab control is created with a border lowered to
- tab control's parent. To remove it, you can apply WS_EX_TRANSPARENT extended
- style (see TControl.ExStyle property), but painting of some child controls
- can be strange a bit in this case (no border drawing for edit controls was
- found, but not always...). You can also apply style WS_THICKFRAME (TControl.Style
- property) to make the border raised.
- |<br> Other methods and properties, suitable for tab control, are:
- |#tabcontrol }
- {$IFNDEF OLD_ALIGN}
- function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
- ImgList: PImageList ): PControl;
- {* |<#control>
- Creates new empty tab control for using metods TC_Insert (to create Pages as Panel),
- or TC_InsertControl (if you want using your custom Pages).}
- {$ENDIF}
-
- //[NewToolbar DECLARATION]
- function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
- Bitmap: HBitmap; const Buttons: array of PKOLChar;
- const BtnImgIdxArray: array of Integer ) : PControl;
- {* |<#control>
- Creates toolbar control. Bitmap (if present) must contain images for all buttons
- excluding separators (defined by string '-' in Buttons array) and system images,
- otherwise last buttons will no have images at all. Image width for every button
- is assumed to be equal to Bitmap height (if last of "squares" has
- insufficient width, it will not be used). To define fixed buttons, use
- characters '+' or '-' as a prefix for button string (even empty). To
- create groups of (radio-)buttons, use also '!' follow '+' or '-'. (These rules
- are similar used in menu creation). To define drop down button, use (as
- first) prefix '^'. (Do not forget to set <D OnTBDropDown> event for this
- case). If You want to assign images to buttons not in the same order
- how these are placed in Bitmap (or You use system bitmap), define for every
- button (in BtnImgIdxArray array) indexes for every button (excluding
- separator buttons). Otherwise, it is possible to define index only for first
- button (e.g., [0]). It is also possible to change TBImages[ ] property
- for such purpose, or do the same in method TBSetBtnImgIdx).
- |<br>
- Following properties, methods and event are specially designed to work with
- toolbar control:
- |#toolbar
- |<br>
- If your project uses Align property to align controls, this can conflict with
- toolbar native aligning. To solve such problem, place toolbar to parent panel,
- which has its own Align property assigned to desired value.
- |<br>
- To create toolbar with buttons, drawn from top to bottom, instead from left
- to right, combine caLeft / caRight in Align parameter and style tboWrapable
- when create toolbar. To adjust width of vertically aligned toolbar, it is
- possible to call ResizeParentLeft for it. E.g.:
-
- ! P0 := NewPanel( W, esRaised ) .SetSize( 30, 0 ) .SetAlign( caLeft );
- ! // ^^^^^^^^^^^^^^^^^ //////
- !TB := NewToolbar( P0, caLeft, [ tboNoDivider, tboWrapable ], DWORD(-1),
- ! // ////// ///////////
- ! [ ' ', ' ', ' ', '-', ' ', ' ' ],
- ! [ STD_FILEOPEN ] ).ResizeParentRight;
- !//Note, that caLeft is *must*, and tboWrapable style too. SetSize for
- !//parent panel is not necessary, but only if ResizeParentRight is called
- !//than for Toolbar.
- |<br><br>
- One more note: if You create toolbar without text labels (passing ' ' for
- each button You add), include also option tboTextRight to fix incorrect
- sizing of buttons under Windows9x.
- |<br>
- And, certainly, if you use image lists rather then bitmap, all written
- above about Bitmap become absolutely incorrect.
- }
-
- //[NewDateTimePicker DECLARATION]
- function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
- : PControl;
- {* |<#control>
- Creates date and time picker common control.
- }
-
- { -- Constructor for Image List objet -- }
-
- //[NewImageList DECLARATION]
- function NewImageList( AOwner: PControl ): PImageList;
- {* Constructor of TImageList object. Unlike other non-visual objects, image list
- can be parented by TControl object (but this does not *must*), and in that
- case it is destroyed automatically when its parent control is destroyed.
- Every control can have several TImageList objects, linked to a simple list.
- But if any TImageList object is destroyed, all following ones are destroyed
- too (at least, now I implemented it so). }
-
- {$ENDIF WIN_GDI}
-
- //[TIMER]
- type
- TTimerKind = ( tkReal, tkProcess, tkProfiler ); // only for UNIX!
- {++}(*TTimer = class;*){--}
- PTimer = {-}^{+}TTimer;
- { ----------------------------------------------------------------------
- TTimer object
- ----------------------------------------------------------------------- }
- //[TTimer DEFINITION]
- TTimer = object( TObj )
- {* Easy timer incapsulation object. It uses separate topmost window,
- common for all timers in the application, to handle WM_TIMER message.
- This allows using timers in non-windowed application (but anyway it
- should contain message handling loop for a thread).
- |<br>
- Note: in UNIX, there are no special windows created, certainly. }
- protected
- fHandle : Integer;
- fEnabled: Boolean;
- fInterval: Integer;
- fOnTimer: TOnEvent;
- {$IFDEF LIN}
- {$IFNDEF GTK}
- {$IFNDEF QT}
- fPrev, fNext: PTimer; // äâóñâÿçíûé ñïèñîê âñåõ _àêòèâíûõ_ òàéìåðîâ
- fTimeStart: clock_t;
- fExpireNext: clock_t;
- fExpireTotal: Int64;
- fTimerHandled: Boolean;
- fResolution: Integer;
- fPeriodic: Boolean;
- fMultimedia: Boolean;
- {$ENDIF QT}
- {$ENDIF GTK}
- {$ENDIF}
- procedure SetEnabled(const Value: Boolean); {$IFDEF WIN} virtual; {$ENDIF}
- procedure SetInterval(const Value: Integer);
- protected
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* Destructor. }
- public
- property Handle : Integer read fHandle;
- {* Windows timer object handle. }
- property Enabled : Boolean read fEnabled write SetEnabled;
- {* True, is timer is on. Initially, always False. }
- property Interval : Integer read fInterval write SetInterval;
- {* Interval in milliseconds (1000 is default and means 1 second).
- Note: in UNIX, if an Interval can be set to a value large then 30 minutes,
- add a conditional definition SUPPORT_LONG_TIMER to the project options. }
- property OnTimer : TOnEvent read fOnTimer write fOnTimer;
- {* Event, which is called when time interval is over. }
- {$IFDEF LIN}
- {$IFNDEF GTK}
- {$IFNDEF QT}
- property Resolution: Integer read fResolution write fResolution; // dummy property, just for compatibility
- property Periodic: Boolean read fPeriodic write fPeriodic;
- {$ENDIF QT}
- {$ENDIF GTK}
- {$ENDIF LIN}
- end;
- //[END OF TTimer DEFINITION]
-
- //[NewTimer DECLARATION]
- function NewTimer( Interval: Integer ): PTimer;
- {* Constructs initially disabled timer with interval 1000 (1 second). }
-
- {$IFDEF WIN}
- {$ifdef win32}
- //[MULTIMEDIA TIMER]
- type
- {++}(*TMMTimer = class;*){--}
- PMMTimer = {-}^{+}TMMTimer;
-
- //[TMMTimer DEFINITION]
- TMMTimer = object( TTimer )
- {* Multimedia timer incapsulation object. Does not require Applet or special
- window to handle it. System creates a thread for each high resolution
- timer, so using many such objects can degrade total PC performance. }
- protected
- FResolution: Integer;
- FPeriodic: Boolean;
- procedure SetEnabled(const Value: Boolean); {-}virtual;{+}{++}(*override;*){--}
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- property Resolution: Integer read FResolution write FResolution;
- {* Minimum timer resolution. The less the more accuracy (0 is exactly
- Interval milliseconds between timer shots). It is recommended to set
- this property greater to prevent entire system from reducing overhead.
- If you change this value, reset and then set Enabled again to apply
- changes. }
- property Periodic: Boolean read FPeriodic write FPeriodic;
- {* TRUE, if timer is periodic (default). Otherwise, timer is one-shot
- (set it Enabled every time in such case for each shot). If you change
- this property, reset and set Enabled property again to get effect. }
- end;
- //[END OF TMMTimer DEFINITION]
-
- //[NewMMTimer DECLARATION]
- function NewMMTimer( Interval: Integer ): PMMTimer;
- {* Creates multimedia timer object. Initially, it has Resolution = 0,
- Periodic = TRUE and Enabled = FALSE. Do not forget also to assign your
- event handler to OnTimer to do something on timer shot. }
- {$endif win32}
- {$ENDIF WIN}
-
- {$IFDEF LIN}
- function NewMMTimer( Interval: Integer ): PTimer;
- {$ENDIF LIN}
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- { -- TTrayIcon object -- }
- //[TRAYICON]
-
- type
- TOnTrayIconMouse = procedure( Sender: PObj; Message : Word ) of object;
- {* Event type to be called when Applet receives a message from an icon,
- added to the taskbar tray. }
-
- {++}(*TTrayIcon = class;*){--}
- PTrayIcon = {-}^{+}TTrayIcon;
- { ----------------------------------------------------------------------
- TTrayIcon - icon in tray area of taskbar
- ----------------------------------------------------------------------- }
- //[TTrayIcon DEFINITION]
- TTrayIcon = object(TObj)
- {* Object to place (and change) a single icon onto taskbar tray. }
- protected
- FIcon: HIcon;
- FActive: Boolean;
- FTooltip: KOLString;
- FOnMouse: TOnTrayIconMouse;
- FControl: PControl;
- fAutoRecreate: Boolean;
- FNoAutoDeactivate: Boolean;
- FWnd: HWnd;
- procedure SetIcon(const Value: HIcon);
- procedure SetActive(const Value: Boolean);
- procedure SetTrayIcon( const Value : DWORD );
- procedure SetTooltip(const Value: KOLString);
- procedure SetAutoRecreate(const Value: Boolean);
- protected
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* Destructor. Use Free method instead (as usual). }
- public
- property Icon : HIcon read FIcon write SetIcon;
- {* Icon to be shown on taskbar tray. If not set, value of Active
- property has no effect. It is also possible to assign a value
- to Icon property after assigning True to Active to install
- icon first time or to replace icon with another one (e.g. to
- get animation effect).
- |<br>
- Previously allocated icon (if any) is not deleted using
- DeleteObject. This is normal for icons, loaded from resource
- (e.g., by LoadIcon API call). But if icon was created (e.g.) by
- CreateIconIndirect, your code is responsible for destroying
- of it). }
- property Active : Boolean read FActive write SetActive;
- {* Set it to True to show assigned Icon on taskbar tray. Default
- is False. Has no effect if Icon property is not assigned.
- TrayIcon is deactivated automatically when Applet is finishing
- (but only if Applet window is used as a "parent" for tray
- icon object). }
- property Tooltip : KOLString read FTooltip write SetTooltip;
- {* Tooltip string, showing automatically when mouse is moving
- over installed icon. Though "huge string" type is used, only
- first 63 characters are considered. Also note, that only in
- most recent versions of Windows multiline tooltips are supported. }
- property OnMouse : TOnTrayIconMouse read FOnMouse write FOnMouse;
- {* Is called then mouse message is taking place concerning installed
- icon. Only type of message can be obtained (e.g. WM_MOUSEMOVE,
- WM_LBUTTONDOWN etc.) }
- property AutoRecreate: Boolean read fAutoRecreate write SetAutoRecreate;
- {* If set to TRUE, auto-recreating of tray icon is proveded in case,
- when Explorer is restarted for some (unpredictable) reasons. Otherwise,
- your tray icon is disappeared forever, and if this is the single way
- to communicate with your application, the user nomore can achieve it. }
- property NoAutoDeactivate: Boolean read FNoAutoDeactivate write FNoAutoDeactivate;
- {* If set to true, tray icon is not removed from tray automatically on
- WM_CLOSE message receive by owner control. Set Active := FALSE in
- your code for such case before accepting closing the form. }
- property Wnd: HWnd read FWnd write FWnd;
- {* A window to use as a base window for tray icon messages. Overrides
- parent Control handle is assigned. Note, that if Wnd property used,
- message handling is not done automatically, and you should do this in
- your code, or at least for one tray icon object, call AttachProc2Wnd. }
- procedure AttachProc2Wnd;
- {* Call this method for a tray icon object in case if Wnd used rather then
- control. It is enough to call this method once for each Wnd used, even
- if several other tray icons are also based on the same Wnd. See also
- DetachProc2Wnd method. }
- procedure DetachProc2Wnd;
- {* Call this method to detach window procedure attached via AttachProc2Wnd.
- Do it once for a Wnd, used as a base to handle tray icon messages.
- Caution! If you do not call this method before destroying Wnd, the
- application will not functioning normally. }
- end;
- {* When You create invisible application, which should be represented by
- only the tray icon, prepare a handle for the window, resposible for
- messages handling. Remember, that window handle is created automatically
- only when a window is showing first time. If window's property Visible is
- set to False, You should to call CreateWindow manually.
- <br>
- There is a known bug exist with similar invisible tray-iconized applications.
- When a menu is activated in response to tray mouse event, if there was
- not active window, belonging to the application, the menu is not disappeared
- when mouse is clicked anywhere else. This bug is occure in Windows9x/ME.
- To avoid it, activate first your form window. This last window shoud have
- status visible (but, certainly, there are no needs to place it on visible
- part of screen - change its position, so it will not be visible for user,
- if You wish).
- <br>
- Also, to make your application "invisible" but until special event is occure,
- use Applet separate from the main form, and make for both Visible := False.
- This allows for You to make your form visible any time You wish, and without
- making application button visible if You do not wish.
- }
- {= Êîãäà Âû äåëàåòå íåâèäèìîå ïðèëîæåíèå, êîòîðîå äîëæíî áûòü ïðåäñòàâëåíî
- òîëüêî èêîíêîé â òðåå, îáåñïå÷üòå íåíóëåâîé Handle äëÿ îêíà, îòâå÷àþùåãî
- çà îáðàáîòêó ñîîáùåíèé. Ïîìíèòå, ÷òî Handle îêíà ñîçäàåòñÿ àâòîìàòè÷åñêè
- òîëüêî â òîò ìîìåíò, êîãäà îíî äîëæíî ïîÿâèòüñÿ â ïåðâûé ðàç. Åñëè ñâîéñòâî
- îêíà Visible óñòàíîâëåíî â FALSE, íåîáõîäèìî âûçâàòü CreateWindow ñàìîñòîÿòåëüíî.
- <br>
- Ñóùåñòâóåò èçâåñòíûé BUG ñ ïîäîáíûìè íåâèäèìûìè ìèíèìèçèðîâàííûìè â òðåé
- ïðèëîæåíèÿìè. Êîãäà â îòâåò íà ñîáûòèå ìûøè àêòèâèçèðâàíî âûïàäàþùåå ìåíþ,
- îíî íå èñ÷åçàåò ïî ùåë÷êó ìûøè âíå ýòîãî ìåíþ. Ïðîèñõîäèò ýòî â Windows9x/ME.
- ÷òîáû ðåøèòü ýòó ïðîáëåìó, ñíà÷àëà àêòèâèçèðóéòå ñâîå îêíî (ôîðìó). Ýòî îêíî
- äîëæíî áûòü âèäèìûì (íî, êîíå÷íî, åãî ìîæíî ðàçìåñòèòü âíå ïðåäåëîâ âèäèìîé
- ÷àñòè ýêðàíà, òàê ÷òî ïîëüçîâàòåëþ åãî âèäíî íå áóäåò).
- <br>
- Òàê æå, ÷òîáû ñäåëàòü ïðèëîæåíèå íåâèäèìûì, ïî êðàéíåé ìåðå, ïîêà ýòî íå
- ïîòðåáóåòñÿ, èñïîëüçóéòå îòäåëüíûé ïðåäñòàâèòåëü êëàññà TControl - ãëîáàëüíóþ
- ïåðåìåííóþ Applet, è ïðèñâîéòå FALSE åå ñâîéñòâó Visible.
- }
- //[END OF TTrayIcon DEFINITION]
-
- //[NewTrayIcon DECLARATION]
- function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
- {* Constructor of TTrayIcon object. Pass main form or applet as Wnd
- parameter. }
-
- //[JUST ONE]
- { -- JustOne -- }
- {$ifndef wince}
- type
- TOnAnotherInstance = procedure( const CmdLine: KOLString ) of object;
- {* Event type to use in JustOneNotify function. }
- {$endif wince}
- function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
- {* Returns True, if this is a first instance. For all other instances
- (application is already running), False is returned. }
- function JustOneActivate( Wnd: PControl; const Identifier : KOLString ) : HWND;
- {* Returns 0, if this is the first instance. If application is running already,
- it will be activated and its window handle will be returned. }
- {$ifndef wince}
- function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
- const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
- {* Returns True, if this is a first instance. For all other instances
- (application is already running), False is returned. If handler
- aOnAnotherInstance passed, it is called (in first instance) every time
- when another instance of an application is started, receiving command
- line used to run it. }
- {$endif wince}
- { -- string (mainly) utility procedures and functions. -- }
-
- {$IFDEF GDI}
- //[Message Box DECLARATIONS]
- function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
- {* Displays message box with the same title as Applet.Caption. If applet
- is not running, and Applet global variable is not assigned, caption
- 'Error' is displayed (but actually this is not an error - the system
- does so, if nil is passed as a title).
- |<br>
- Returns ID_... result (correspondently to flags passed (MB_OK, MBYESNO,
- etc. -> ID_OK, ID_YES, ID_NO, etc.) }
- procedure MsgOK( const S: KOLString );
- {* Displays message box with the same title as Applet.Caption (or 'Error',
- if Applet is not running). }
- function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
- {* Displays message box like MsgBox, but uses Applet.Handle as a parent
- (so the message has no button on a task bar). }
- procedure ShowMessage( const S: KOLString );
- {* Like ShowMsg, but has only styles MB_OK and MB_SETFOREGROUND. }
- {$ENDIF GDI}
- {$IFDEF WIN}
- procedure SpeakerBeep( Freq: Word; Duration: DWORD );
- {* On Windows NT, calls Windows.Beep. On Windows 9x, produces beep on speaker
- of desired frequency during given duration time (in milliseconds). }
- {$ENDIF WIN}
-
- {++}(*
- function FormatMessage(dwFlags: DWORD; lpSource: Pointer; dwMessageId: DWORD; dwLanguageId: DWORD;
- lpBuffer: PChar; nSize: DWORD; Arguments: Pointer): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- *){--}
- function SysErrorMessage(ErrorCode: Integer): KOLString;
- {* Creates and returns a string containing formatted system error message.
- It is possible then to display this message or write it to a log
- file, e.g.:
- ! ShowMsg( SysErrorMessage( GetLastError ) );
-
- |&R=<a name="%0"></a><font color=#FF8040><h1>%0</h1></font>
- <R 64-bit integer numbers>
- }
- {$ENDIF WIN_GDI}
- //[I64 TYPE]
- type
- I64 = record
- {* 64 bit integer record. Use it and correspondent functions below in KOL
- projects to avoid dependancy from Delphi version (earlier versions of
- Delphi had no Int64 type). }
- Lo, Hi: DWORD;
- end;
- PI64 = ^I64;
- {* }
-
- {-}
- {$IFNDEF _D4orHigher}
- Int64 = I64;
- PInt64 = PI64;
- {$ENDIF}
-
- function MakeInt64( Lo, Hi: DWORD ): I64;
- {* }
- function Int2Int64( X: Integer ): I64;
- {* }
- procedure IncInt64( var I64: I64; Delta: Integer );
- {* I64 := I64 + Delta; }
- procedure DecInt64( var I64: I64; Delta: Integer );
- {* I64 := I64 - Delta; }
- function Add64( const X, Y: I64 ): I64;
- {* Result := X + Y; }
- function Sub64( const X, Y: I64 ): I64;
- {* Result := X - Y; }
- function Neg64( const X: I64 ): I64;
- {* Result := -X; }
- function Mul64i( const X: I64; Mul: Integer ): I64;
- {* Result := X * Mul; }
- function Div64i( const X: I64; D: Integer ): I64;
- {* Result := X div D; }
- function Mod64i( const X: I64; D: Integer ): Integer;
- {* Result := X mod D; }
- function Sgn64( const X: I64 ): Integer;
- {* Result := sign( X ); i.e.:
- |<br>
- if X < 0 then -1
- |<br>
- if X = 0 then 0
- |<br>
- if X > 0 then 1 }
- function Cmp64( const X, Y: I64 ): Integer;
- {* Result := sign( X - Y ); i.e.
- |<br>
- if X < Y then -1
- |<br>
- if X = Y then 0
- |<br>
- if X > Y then 1 }
- function Int64_2Str( X: I64 ): String;
- {* }
- function Int64_2Hex( X: I64; MinDigits: Integer ): String;
- {* }
- function Str2Int64( const S: String ): I64;
- {* }
- function Int64_2Double( const X: I64 ): Double;
- {* }
- function Double2Int64( D: Double ): I64;
- {*
-
- <R Floating point numbers>
- }
-
- const
- NAN = 0.0 / 0.0;
- Infinity = 1.0 / 0.0;
- {+}
- {++}(*const NAN = 1e-100;*){--}
-
- function IsNan(const AValue: Double): Boolean;
- {* Checks if an argument passed is NAN. }
- function IsInfinity(const AValue: Double): Boolean;
- {* Checks if an argument passed is Infinite. }
-
- function IntPower(Base: Extended; Exponent: Integer): Extended;
- {* Result := Base ^ Exponent; }
-
- //[String<->Double DECLARATIONS]
- function Str2Double( const S: String ): Double;
- {* }
-
- function Str2Extended( const S: String ): Extended;
- {* }
-
- function Double2Str( D: Double ): String;
- {* }
- function Extended2Str( E: Extended ): String;
- {* }
-
- function Double2StrEx( D: Double ): String;
- {* experimental, do not use }
-
- function TruncD( D: Double ): Double;
- {* Result := trunc( D ) as Double;
- |<hr>
-
- <R Small bit arrays (max 32 bits in array)>
- See also TBits object.
- }
-
- function IfThenElseBool( t, e, Cond: Boolean ): Boolean;
- function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
- function IfThenElseStr( const t, e: String; Cond: Boolean ): String;
- {$IFDEF _D5orHigher}
- function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
- function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
- function IfThenElse( t, e: String; Cond: Boolean ): String; overload;
- function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
- {$ENDIF}
-
- //[SMALL BIT ARRAYS DECLARATIONS]
- function GetBits( N: DWORD; first, last: Byte ): DWord;
- {* Retuns bits straing from <first> and to <last> inclusively. }
- function GetBitsL( N: DWORD; from, len: Byte ): DWord;
- {* Retuns len bits starting from index <from>.
- |<hr>
-
- <R Arithmetics, geometry and other utility functions>
-
- See also units KolMath.pas, CplxMath.pas and Err.pas.
- }
- //[MulDiv DECLARATION]
- {$IFNDEF FPC}
- function MulDiv( A, B, C: Integer ): Integer;
- {* Returns A * B div C. Small and fast. }
- {$ENDIF}
-
- //[TMethod TYPE]
- type
- ///////////////////////////////////////////
- {$ifndef _D6orHigher} //
- ///////////////////////////////////////////
- TMethod = {$ifndef wince}packed{$endif} record
- {* Is defined here because using of VCL classes.pas unit is
- not recommended in XCL. This record type is used often
- to set/access event handlers, referring to a procedure
- of object (usually to set such event to an ordinal
- procedure setting Data field to nil. }
- Code: Pointer; // Pointer to method code.
- {* If used to fake assigning to event handler of type 'procedure
- of object' with ordinal procedure pointer, use symbol '@'
- before method:
- |<br> <font face="Courier"><b>
- | Method.Code := @MyProcedure;
- |</b></font> }
- Data: Pointer; // Pointer to object, owning the method.
- {* To fake event of type 'procedure of object' with setting it to
- ordinal procedure assign here NIL; }
- end;
- {* When assigning TMethod record to event handler, typecast it with
- desired event type, e.g.:
- |<br> <font face="Courier"><b>
- | SomeObject.OnSomeEvent := TOnSomeEvent( Method );
- |</b></font><br> }
- ///////////////////////////////////////////
- {$endif} //
- ///////////////////////////////////////////
- PMethod = ^TMethod;
- {* }
-
- function MakeMethod( Data, Code: Pointer ): TMethod;
- {* Help function to construct TMethod record. Can be useful to
- assign regular type procedure/function as event handler for
- event, defined as object method (do not forget, that in that
- case it must have first dummy parameter to replace @Self,
- passed in EAX to methods of object). }
-
- //[Rectangles&Points DECLARATIONS]
- function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; {$ifdef wince}cdecl{$else}stdcall{$endif};
- {* Use it instead of VCL Rect function }
- function RectsEqual( const R1, R2: TRect ): Boolean;
- {* Returns True if rectangles R1 and R2 have the same bounds }
- function RectsIntersected( const R1, R2: TRect ): Boolean;
- {* Returns TRUE if rectangles R1 and R2 have at least one common point.
- Note, that right and bottom bounds of rectangles are not their part,
- so, if such points are lying on that bounds, FALSE is returned. }
- function PointInRect( const P: TPoint; const R: TRect ): Boolean;
- {* Returns True if point P is located in rectangle R (including
- left and top bounds but without right and bottom bounds of the
- rectangle). }
- function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
- {* }
- function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
- {* }
- function Point2SmallPoint( const T: TPoint ): TSmallPoint;
- {* }
- function SmallPoint2Point( const T: TSmallPoint ): TPoint;
- {* }
- function MakePoint( X, Y: Integer ): TPoint;
- {* Use instead of VCL function Point }
- function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
- {* Use to construct TSmallPoint }
- //[MakeFlags DECLARATION]
- function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
- {* }
-
- function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
- {* Returns TDateTimeRange from two TDateTime bounds. }
-
- //[Integer FUNCTIONS DECLARATIONS]
- procedure Swap( var X, Y: Integer );
- {* exchanging values }
- function Min( X, Y: Integer ): Integer;
- {* minimum of two integers }
- function Max( X, Y: Integer ): Integer;
- {* maximum of two integers }
- {$IFDEF REDEFINE_ABS}
- function Abs( X: Integer ): Integer;
- {* absolute value }
- {$ENDIF}
- function Sgn( X: Integer ): Integer;
- {* sign of X: if X < 0, -1 is returned, if > 0, then +1, otherwise 0. }
- function iSqrt( X: Integer ): Integer;
- {* square root }
- function iCbrt( X: DWORD ): Integer;
- {* cubic root
- |<hr>
-
- <R String to number and number to string conversions>
- }
- //[Integer<->String DECLARATIONS]
- function Int2Hex( Value : DWord; Digits : Integer ) : String;
- {* Converts integer Value into string with hex number. Digits parameter
- determines minimal number of digits (will be completed by adding
- necessary number of leading zeroes). }
- function Int2Str( Value : Integer ) : String;
- {* Obvious. }
- procedure Int2PChar( s: PChar; Value: Integer );
- {* Converts Value to string and puts it into buffer s. Buffer must have
- enough size to store the number converted: buffer overflow does
- not checked anyway! }
- function UInt2Str( Value: DWORD ): String;
- {* The same as Int2Str, but for unsigned integer value. }
- function Int2StrEx( Value, MinWidth: Integer ): String;
- {* Like Int2Str, but resulting string filled with leading spaces to provide
- at least MinWidth characters. }
- function Int2Rome( Value: Integer ): String;
- {* Represents number 1..8999 to Rome numer. }
- function Int2Ths( I : Integer ) : String;
- {* Converts integer into string, separating every three digits from each
- other by character ThsSeparator. (Convert to thousands). You }
- function Int2Digs( Value, Digits : Integer ) : String;
- {* Converts integer to string, inserting necessary number of leading zeroes
- to provide desired length of string, given by Digits parameter. If
- resulting string is greater then Digits, string is not truncated anyway. }
- function Num2Bytes( Value : Double ) : String;
- {* Converts double float to string, considering it as a bytes count.
- If Value is sufficiently large, number is represented in kilobytes (with
- following letter K), or in megabytes (M), gigabytes (G) or terabytes (T).
- Resulting string number is truncated to two decimals (.XX) or to one (.X),
- if the second is 0. }
- function S2Int( S: PChar ): Integer;
- {* Converts null-terminated string to Integer. Scanning stopped when any
- non-digit character found. Even empty string or string not containing
- valid integer number silently converted to 0. }
- function Str2Int(const Value : String) : Integer;
- {* Converts string to integer. First character, which can not be
- recognized as a part of number, regards as a separator. Even
- empty string or string without number silently converted to 0. }
- function Hex2Int( const Value : String) : Integer;
- {* Converts hexadecimal number to integer. Scanning is stopped
- when first non-hexadicimal character is found. Leading dollar ('$')
- character is skept (if present). Minus ('-') is not concerning as
- a sign of number and also stops scanning.}
- function cHex2Int( const Value : String) : Integer;
- {* As Hex2Int, but also checks for leading '0x' and skips it. }
- function Octal2Int( const Value: String ) : Integer;
- {* Converts octal number to integer. Scanning is stopped on first
- non-octal digit (any char except 0..7). There are no checking if
- there octal numer in the parameter. If the first char is not octal
- digit, 0 is returned. }
- function Binary2Int( const Value: String ) : Integer;
- {* Converts binary number to integer. Like Octal2Int, but only digits
- 0 and 1 are allowed. }
- {$IFDEF WIN}
- {$IFNDEF _FPC}
- function Format( const fmt: KOLString; params: array of const ): KOLString;
- {* Uses API call to wvsprintf, so does not understand extra formats,
- such as floating point, date/time, currency conversions. See list of
- available formats in win32.hlp (topic wsprintf).
- |<hr>
-
- <R Working with null-terminated and ansi strings>
- }
- {$ENDIF _FPC}
- {$ENDIF WIN}
- //[String FUNCTIONS DECLARATIONS]
- function StrComp(const Str1, Str2: PChar): Integer;
- {* Compares two strings fast. -1: Str1<Str2; 0: Str1=Str2; +1: Str1>Str2 }
- function StrComp_NoCase(const Str1, Str2: PChar): Integer;
- {* Compares two strings fast without case sensitivity.
- Returns: -1 when Str1<Str2; 0 when Str1=Str2; +1 when Str1>Str2 }
- function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
- {* Compare two strings (fast). Terminating 0 is not considered, so if
- strings are equal, comparing is continued up to MaxLen bytes.
- Since this, pass minimum of lengths as MaxLen. }
- function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
- {* Compare two strings fast without case sensitivity.
- Terminating 0 is not considered, so if strings are equal,
- comparing is continued up to MaxLen bytes.
- Since this, pass minimum of lengths as MaxLen. }
- function StrCopy( Dest, Source: PChar ): PChar;
- {* Copy source string to destination (fast). Pointer to Dest is returned. }
- function StrCat( Dest, Source: PChar ): PChar;
- {* Append source string to destination (fast). Pointer to Dest is returned. }
- function StrLen(const Str: PChar): Cardinal;
- {* StrLen returns the number of characters in Str, not counting the null
- terminator. }
- function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar;
- {* Fast scans string Str of length Len searching character Chr.
- Pointer to a character next to found or to Str[Len] (if no one found)
- is returned. }
- function StrScan(Str: PChar; Chr: Char): PChar;
- {* Fast search of given character in a string. Pointer to found character
- (or nil) is returned. }
- function StrRScan(const Str: PChar; Chr: Char): PChar;
- {* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
- does not occur in Str, StrRScan returns NIL. The null terminator is
- considered to be part of the string. }
- function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
- {* Returns True, if string Str is starting from Pattern, i.e. if
- Copy( Str, 1, StrLen( Pattern ) ) = Pattern. Str must not be nil! }
- function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
- {* Like StrIsStartingFrom above, but without case sensitivity. }
- function TrimLeft(const S: KOLstring): KOLstring;
- {* Removes spaces, tabulations and control characters from the starting
- of string S. }
- function TrimRight(const S: KOLstring): KOLstring;
- {* Removes spaces, tabulates and other control characters from the
- end of string S. }
- function Trim( const S : KOLstring): KOLstring;
- {* Makes TrimLeft and TrimRight for given string. }
- function RemoveSpaces( const S: String ): String;
- {* Removes all characters less or equal to ' ' in S and returns it. }
- procedure Str2LowerCase( S: PChar );
- {* Converts null-terminated string to lowercase (inplace). }
- function LowerCase(const S: string): string;
- {* Obvious. }
- function UpperCase(const S: string): string;
- {* Obvious. }
- function AnsiUpperCase(const S: string): string;
- {* Obvious. }
- function AnsiLowerCase(const S: string): string;
- {* Obvious. }
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
- function WAnsiUpperCase(const S: WideString): WideString;
- {* Obvious. }
- function WAnsiLowerCase(const S: WideString): WideString;
- {* Obvious. }
- function WStrComp(const S1, S2: WideString): Integer;
- {* }
- function _WStrComp(S1, S2: PWideChar): Integer;
- {* }
- function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
- {* Fast search of given character in a string. Pointer to found character
- (or nil) is returned. }
- function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
- {* StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr
- does not occur in Str, StrRScan returns NIL. The null terminator is
- considered to be part of the string. }
- {$ENDIF _FPC}
- {$ENDIF _D2}
- function AnsiCompareStr(const S1, S2: KOLString): Integer;
- {* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
- operation is controlled by the current Windows locale. The return value
- is the same as for CompareStr. }
- function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
- {* The same, but for PChar ANSI strings }
- function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
- {* AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare
- operation is controlled by the current Windows locale. The return value
- is the same as for CompareStr. }
- function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
- {* The same, but for PChar ANSI strings }
- function AnsiCompareText( const S1, S2: String ): Integer;
- {* }
-
- {$IFDEF WIN}
- {$IFNDEF _FPC}
- function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;
- {* from Delphi5 - because D2 does not contain it. }
- function LStrFromPWChar(Source: PWideChar): String;
- {* from Delphi5 - because D2 does not contain it. }
- {$ENDIF _FPC}
- {$ENDIF WIN}
-
- function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
- {* Returns copy of source string S starting from Idx up to the end of
- string S. Works correctly for case, when Idx > Length( S ) (returns
- empty string for such case). }
- function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
- {* Returns last Len characters of the source string. If Len > Length( S ),
- entire string S is returned. }
- procedure DeleteTail( var S : KOLString; Len : Integer );
- {* Deletes last Len characters from string. }
- function IndexOfChar( const S : String; Chr : Char ) : Integer;
- {* Returns index of given character (1..Length(S)), or
- -1 if a character not found. }
- function IndexOfCharsMin( const S, Chars : String ) : Integer;
- {* Returns index (in string S) of those character, what is taking place
- in Chars string and located nearest to start of S. If no such
- characters in string S found, -1 is returned. }
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
- function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;
- {* Returns index (in wide string S) of those wide character, what
- is taking place in Chars wide string and located nearest to start of S.
- If no such characters in string S found, -1 is returned. }
- {$ENDIF _FPC}
- {$ENDIF _D2}
-
- function IndexOfStr( const S, Sub : String ) : Integer;
- {* Returns index of given substring in source string S. If found,
- 1..Length(S)-Length(Sub), if not found, -1. }
- function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
- {* Returns first characters of string S, separated from others by
- one of characters, taking place in Separators string, assigning
- a tail of string (after found separator) to source string. If
- no separator characters found, source string S is returned, and
- source string itself becomes empty. }
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- function WParse( var S : WideString; const Separators : WideString ) : WideString;
- {* Returns first wide characters of wide string S, separated from others
- by one of wide characters, taking place in Separators wide string,
- assigning a tail of wide string (following found separator) to the
- source one. If there are no separator characters found, source wide
- string S is returned, and source wide string itself becomes empty. }
- {$ENDIF _D2}
- {$ENDIF _FPC}
- function ParsePascalString( var S : String; const Separators : String ) : String;
- {* Returns first characters of string S, separated from others by
- one of characters, taking place in Separators string, assigning
- a tail of string (after the found separator) to source string. If
- there are no separator characters found, the source string S is returned,
- and the source string itself becomes empty. Additionally: if the first (after
- a blank space) is the quote "'" or '#', pascal string is assumung first
- and is converted to usual string (without quotas) before analizing
- of other separators. }
- function String2PascalStrExpr( const S : String ) : String;
- {* Converts string to Pascal-like string expression (concatenation of
- strings with quotas and characters with leading '#'). }
- function StrEq( const S1, S2 : String ) : Boolean;
- {* Returns True, if LowerCase(S1) = LowerCase(S2). I.e., if strings
- are equal to each other without caring of characters case sensitivity
- (ASCII only). }
- function AnsiEq( const S1, S2 : String ) : Boolean;
- {* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
- stringsare equal to each other without caring of characters case
- sensitivity. }
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
- function WAnsiEq( const S1, S2 : WideString ) : Boolean;
- {* Returns True, if AnsiLowerCase(S1) = AnsiLowerCase(S2). I.e., if ANSI
- stringsare equal to each other without caring of characters case
- sensitivity. }
- {$ENDIF _FPC}
- {$ENDIF _D2}
-
- function StrIn( const S : String; const A : array of String ) : Boolean;
- {* Returns True, if S is "equal" to one of strings, taking place
- in A array. To check equality, StrEq function is used, i.e.
- comaprison is taking place without case sensitivity. }
- {$IFNDEF _FPC}
- type TSetOfChar = Set of Char;
- {$IFNDEF _D2}
- function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
- {* Returns True, if S is "equal" to one of strings, taking place
- in A array. To check equality, WAnsiEq function is used, i.e.
- comaprison is taking place without case sensitivity. }
- function CharIn( C: KOLChar; const A: TSetOfChar ): Boolean;
- {* To replace expressions like S[1] in [ '0'..'z' ] to CharIn( S[ 1 ], [ '0'..'z' ] )
- (and to avoid problems with Unicode version of code). }
- {$ENDIF _D2}
- {$ENDIF _FPC}
- function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;
- {* Returns True, if S is "equal" to one of strings, taking place
- in A array, and in such Case Idx also is assigned to an index of A element
- equal to S. To check equality, StrEq function is used, i.e.
- comaprison is taking place without case sensitivity. }
- function IntIn( Value: Integer; const List: array of Integer ): Boolean;
- {* Returns TRUE, if Value is found in a List. }
- function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
- {* }
- function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
- {* }
- function StrSatisfy( const S, Mask : KOLString ) : Boolean;
- {* Returns True, if S is satisfying to a given Mask (which can contain
- wildcard symbols '*' and '?' interpeted correspondently as 'any
- set of characters' and 'single any character'. If there are no
- such wildcard symbols in a Mask, result is True only if S is maching
- to Mask string.) }
- function StrReplace( var S: String; const From, ReplTo: String ): Boolean;
- {* Replaces first occurance of From to ReplTo in S, returns True,
- if pattern From was found and replaced. }
- function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
- {* Replaces first occurance of From to ReplTo in S, returns True,
- if pattern From was found and replaced. }
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
- {* Replaces first occurance of From to ReplTo in S, returns True,
- if pattern From was found and replaced. See also function StrReplace.
- This function is not available in Delphi2 (this version of Delphi
- does not support WideString type). }
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- function StrRepeat( const S: String; Count: Integer ): String;
- {* Repeats given string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- function WStrRepeat( const S: WideString; Count: Integer ): WideString;
- {* Repeats given wide string Count times. E.g., StrRepeat( 'A', 5 ) gives 'AAAAA'. }
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- procedure NormalizeUnixText( var S: String );
- {* In the string S, replaces all occurances of character #10 (without leading #13)
- to the character #13. }
- procedure Koi8ToAnsi( s: PChar );
- {* Converts Koi8 text to Ansi (in place) }
-
- function StrPCopy(Dest: PChar; const Source: string): PChar;
- {* Copyes Pascal-style string into null-terminaed one. }
- function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;
- {* Copyes first MaxLen characters of Pascal-style string into
- null-terminated one. }
-
- function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
- {* Returns index of the last of delimiters given by same named parameter
- among characters of Str. If there are no delimiters found, length of
- Str is returned. This function is intended mainly to use in filename
- parsing functions. }
- function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
- {* Returns address of the last of delimiters given by Delimiters parameter
- among characters of Str. If there are no delimeters found, position of
- the null terminator in Str is returned. This function is intended
- mainly to use in filename parsing functions. }
- {$IFDEF _D3orHigher}
- function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
- {* }
- {$ENDIF _D3orHigher}
- function SkipSpaces( P: PKOLChar ): PKOLChar;
- {* Skips all characters #1..' ' in a string.
- }
- {$IFDEF F_P}
- function DummyStrFun( const S: String ): String;
- {$ENDIF}
-
- //[Memory FUNCTIONS DECLARATIONS]
- function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
- {* Fast compare of two memory blocks. }
- function AllocMem( Size : Integer ) : Pointer;
- {* Allocates global memory and unlocks it. }
- procedure DisposeMem( var Addr : Pointer );
- {* Locks global memory block given by pointer, and frees it.
- Does nothing, if the pointer is nil.
- |<hr>
-
- <R Text in clipboard operations>
- }
- {$IFDEF WIN_GDI}
-
- //[clipboard FUNCTIONS DECLARATIONS]
- function ClipboardHasText: Boolean;
- {* Returns true, if the clipboard contain text to paste from. }
- function Clipboard2Text: String;
- {* If clipboard contains text, this function returns it for You. }
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- function Clipboard2WText: WideString;
- {* If clipboard contains text, this function returns it for You (as Unicode string). }
- {$ENDIF _D2}
- {$ENDIF _FPC}
- function Text2Clipboard( const S: String ): Boolean;
- {* Puts given string to a clipboard. }
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- function WText2Clipboard( const WS: WideString ): Boolean;
- {* Puts given Unicode string to a clipboard.
- |<hr>
- }
- {$ENDIF _D2}
- {$ENDIF _FPC}
- {$ifdef win32}
- //[Mnemonics FUNCTIONS DECLARATIONS]
- var SearchMnemonics: function ( const S: KOLString ): KOLString
- = {$IFDEF F_P} DummyStrFun {$ELSE}
- {$IFDEF UNICODE_CTRLS} WAnsiUpperCase {$ELSE} AnsiUpperCase {$ENDIF} {$ENDIF};
- MnemonicsLocale: Integer;
-
- procedure SupportAnsiMnemonics( LocaleID: Integer );
- {* Provides encoding to work with given locale. Call this global function to
- extend TControl.SupportMnemonics capability (also should be called for a form
- or for Applet variable).
-
- <R Date and time handling>
- }
- {$endif win32}
- {$ENDIF WIN_GDI}
- {$IFDEF WIN_GDI}
- //[TDateTime TYPE DEFINITION]
- type
- //TDateTime = Double; // well, it is already defined so in System.pas
- {* Basic date and time type. Integer part represents year and days (as is,
- i.e. 1-Jan-2000 is representing by value 730141, which is a number of
- days from 1-Jan-0001 to 1-Jan-2000 inclusively). Fractional part is
- representing hours, minutes, seconds and milliseconds of a day
- proportionally (like in VCL TDateTime type, e.g. 0.5 = 12:00, 0.25 = 6:00,
- etc.). }
-
- PDayTable = ^TDayTable;
- TDayTable = array[1..12] of Word;
-
- TDateFormat = ( dfShortDate, dfLongDate );
- {* Date formats available to use in formatting date/time to string. }
- TTimeFormatFlag = ( tffNoMinutes, tffNoSeconds, tffNoMarker, tffForce24 );
- {* Additional flags, used for formatting time. }
- TTimeFormatFlags = Set of TTimeFormatFlag;
- {* Set of flags, used for formatting time. }
-
- const
- MonthDays: array [Boolean] of TDayTable =
- ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
- (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
- {* The MonthDays array can be used to quickly find the number of
- days in a month: MonthDays[IsLeapYear(Y), M]. }
-
- SecsPerDay = 24 * 60 * 60;
- {* Seconds per day. }
- MSecsPerDay = SecsPerDay * 1000;
- {* Milliseconds per day. }
-
- VCLDate0 = 693594;
- {* Value to convert VCL "date 0" to KOL "date 0" and back.
- This value corresponds to 30-Dec-1899, 0:00:00. So,
- to convert VCL date to KOL date, just subtract this
- value from VCL date. And to convert back from KOL date
- to VCL date, add this value to KOL date.}
-
- {++}(*
- procedure GetLocalTime(var lpSystemTime: TSystemTime); {$ifdef wince}cdecl{$else}stdcall{$endif};
- procedure GetSystemTime(var lpSystemTime: TSystemTime); {$ifdef wince}cdecl{$else}stdcall{$endif};
- *){--}
-
- //[Date&Time FUNCTIONS DECLARATIONS]
- function Now : TDateTime;
- {* Returns local date and time on running PC. }
- function Date: TDateTime;
- {* Returns todaylocal date. }
- procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
- {* Decodes date. }
- procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
- {* Decodes date. }
- function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
- {* Encodes date. }
- function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
- {* Compares to TSystemTime records. Returns -1, 0, or 1 if, correspondantly,
- D1 < D2, D1 = D2 and D1 > D2. }
- procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
- {* Increases/decreases day in TSystemTime record onto given days count
- (can be negative). }
- procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
- {* Increases/decreases month number in TSystemTime record onto given
- months count (can be negative). Correct result is not garantee if
- day number is incorrect for newly obtained month. }
- function IsLeapYear(Year: Integer): Boolean;
- {* Returns True, if given year is "leap" (i.e. has 29 days in the February). }
- function DayOfWeek(Date: TDateTime): Integer;
- {* Returns day of week (0..6) for given date. }
- function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
- {* Converts TSystemTime record to XDateTime variable. }
- function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
- {* Converts TDateTime variable to TSystemTime record. }
- function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
- {* Converts DTSys representing system time (+0 Grinvich) to local time. }
- function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
- {* Converts DTLoc representing local time to system time (+0 Grinvich) }
- function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
- {* }
- function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
- {* }
-
- procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
- {* Dividing of integer onto divisor with obtaining both result of division
- and remainder. }
-
- function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
- const DfltDateFormat : TDateFormat;
- const DateFormat : PKOLChar ) : KOLString;
- {* Formats date, stored in TSystemTime record into string, using given locale
- and date/time formatting flags. (E.g.: GetUserDefaultLangID). }
- function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
- const Flags : TTimeFormatFlags;
- const TimeFormat : PKOLChar ) : KOLString;
- {* Formats time, stored in TSystemTime record into string, using given locale
- and date/time formatting flags. }
-
- function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
- {* Represents date as a string correspondently to Fmt formatting string.
- See possible pictures in definition of the function Str2DateTimeFmt
- (the first part). If Fmt string is empty, default system date format
- for short date string used. }
- function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
- {* Represents time as a string correspondently to Fmt formatting string.
- See possible pictures in definition of the function Str2DateTimeFmt
- (the second part). If Fmt string is empty, default system time format
- for short date string used. }
- function DateTime2StrShort( D: TDateTime ): String;
- {* Formats date and time to string in short date format using current user
- locale. }
- function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
- {* Restores date or/and time from string correspondently to a format string.
- Date and time formatting string can contain following pictures (case
- sensitive):
- |<pre>
- DATE PICTURES
- d Day of the month as digits without leading zeros for single digit days.
- dd Day of the month as digits with leading zeros for single digit days
- ddd Day of the week as a 3-letter abbreviation as specified by a
- LOCALE_SABBREVDAYNAME value.
- dddd Day of the week as specified by a LOCALE_SDAYNAME value.
- M Month as digits without leading zeros for single digit months.
- MM Month as digits with leading zeros for single digit months
- MMM Month as a three letter abbreviation as specified by a LOCALE_SABBREVMONTHNAME value.
- MMMM Month as specified by a LOCALE_SMONTHNAME value.
- y Year represented only be the last digit.
- yy Year represented only be the last two digits.
- yyyy Year represented by the full 4 digits.
- gg Period/era string as specified by the CAL_SERASTRING value. The gg
- format picture in a date string is ignored if there is no associated era
- string. In Enlish locales, usual values are BC or AD.
-
- TIME PICTURES
- h Hours without leading zeros for single-digit hours (12-hour clock).
- hh Hours with leading zeros for single-digit hours (12-hour clock).
- H Hours without leading zeros for single-digit hours (24-hour clock).
- HH Hours with leading zeros for single-digit hours (24-hour clock).
- m Minutes without leading zeros for single-digit minutes.
- mm Minutes with leading zeros for single-digit minutes.
- s Seconds without leading zeros for single-digit seconds.
- ss Seconds with leading zeros for single-digit seconds.
- t One character–time marker string (usually P or A, in English locales).
- tt Multicharacter–time marker string (usually PM or AM, in English locales).
- |</pre>
- E.g., 'D, yyyy/MM/dd h:mm:ss'.
- See also Str2DateTimeShort function.
- }
- function Str2DateTimeShort( const S: String ): TDateTime;
- {* Restores date and time from string correspondently to current user locale. }
- function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
- {* Like Str2DateTimeShort above, but uses locale defined date and time
- separators to avoid recognizing time as a date in some cases.
- |<hr>
-
- <R File and directory routines>
- }
- {$ENDIF WIN_GDI}
-
- //[OpenFile CONSTANTS]
- const
- ofOpenRead = {$IFDEF LIN} O_RDONLY {$ELSE} $80000000 {$ENDIF};
- {* Use this flag (in combination with others) to open file for "read" only. }
- ofOpenWrite = {$IFDEF LIN} O_WRONLY {$ELSE} $40000000 {$ENDIF};
- {* Use this flag (in combination with others) to open file for "write" only. }
- ofOpenReadWrite = {$IFDEF LIN} O_RDWR {$ELSE} $C0000000 {$ENDIF};
- {* Use this flag (in combination with others) to open file for "read" and "write". }
-
- ofShareExclusive = {$IFDEF LIN} $10 {$ELSE} $00 {$ENDIF};
- {* Use this flag (in combination with others) to open file for exclusive use. }
- ofShareDenyWrite = {$IFDEF LIN} $20 {$ELSE} $01 {$ENDIF};
- {* Use this flag (in combination with others) to open file in share mode, when
- only attempts to open it in other process for "write" will be impossible.
- I.e., other processes could open this file simultaneously for read only
- access. }
- ofShareDenyRead = {$IFDEF LIN} 0 {not supported} {$ELSE} $02 {$ENDIF};
- {* Use this flag (in combination with others) to open file in share mode, when
- only attempts to open it for "read" in other processes will be disabled.
- I.e., other processes could open it for "write" only access. }
- ofShareDenyNone = {$IFDEF LIN} $30 {$ELSE} $03 {$ENDIF};
- {* Use this flag (in combination with others) to open file in full sharing mode.
- I.e. any process will be able open this file using the same share flag. }
- ofCreateNew = {$IFDEF LIN} O_CREAT or O_TRUNC {$ELSE} $100 {$ENDIF};
- {* Default creation disposition. Use this flag for creating new file (usually
- for write access. }
- ofCreateAlways = {$IFDEF LIN} O_CREAT {$ELSE} $200 {$ENDIF};
- {* Use this flag (in combination with others) to open existing or creating new
- file. If existing file is opened, it is truncated to size 0. }
- ofOpenExisting = {$IFDEF LIN} 0 {$ELSE} $300 {$ENDIF};
- {* Use this flag (in combination with others) to open existing file only. }
- ofOpenAlways = {$IFDEF LIN} O_CREAT {$ELSE} $400 {$ENDIF};
- {* Use this flag (in combination with others) to open existing or create new
- (if such file is not yet exists). }
- ofTruncateExisting = {$IFDEF LIN} O_TRUNC {$ELSE} $500 {$ENDIF};
- {* Use this flag (in combination with others) to open existing file and truncate
- it to size 0. }
-
- ofAttrReadOnly = {$IFDEF LIN} 0 {$ELSE} $10000 {$ENDIF};
- {* Use this flag to create Read-Only file (?). }
- ofAttrHidden = {$IFDEF LIN} 0 {$ELSE} $20000 {$ENDIF};
- {* Use this flag to create hidden file. }
- ofAttrSystem = {$IFDEF LIN} 0 {$ELSE} $40000 {$ENDIF};
- {* Use this flag to create system file. }
- ofAttrTemp = {$IFDEF LIN} 0 {$ELSE} $1000000 {$ENDIF};
- {* Use this flag to create temp file. }
- ofAttrArchive = {$IFDEF LIN} 0 {$ELSE} $200000 {$ENDIF};
- {* Use this flag to create archive file. }
- ofAttrCompressed = {$IFDEF LIN} 0 {$ELSE} $8000000 {$ENDIF};
- {* Use this flag to create compressed file. Has effect only on NTFS, and
- only if ofAttrCompressed is not specified also. }
- ofAttrOffline = {$IFDEF LIN} 0 {$ELSE} $10000000 {$ENDIF};
- {* Use this flag to create offline file. }
- //[END OF OpenFileConstants]
-
- //[File FUNCTIONS DECLARATIONS]
- {$IFDEF _D3orHigher}
- function WFileCreate(const FileName: WideString; OpenFlags: DWord): THandle;
- {* }
- {$ENDIF}
- function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
- {* Call this function to open existing or create new file. OpenFlags
- parameter can be a combination of up to three flags (by one from
- each group:
- |<table border=0>
- |&L=<tr><td valign=top>%0</td><td valign=top>
- |&E=</td></tr>
- <L ofOpenRead, ofOpenWrite, ofOpenReadWrite> - 1st group. Here You decide
- wish You open file for read, write or read-and-write operations; <E>
- <L ofShareExclusive, ofShareDenyWrite, ofShareDenyRead, ofShareDenyNone> -2nd
- group - sharing. Here You can mark out sharing mode, which is used to
- open file. <E>
- <L ofCreateNew, ofCreateAlways, ofOpenExisting, ofOpenAlways, ofTruncateExisting>
- - 3rd group - creation disposition. Here You determine, either to create new
- or open existing file and if to truncate existing or not.
- |</table> }
- function FileClose(Handle: THandle): Boolean;
- {* Call it to close opened earlier file. }
- function FileExists( const FileName: KOLString ) : Boolean;
- {* Returns True, if given file exists.
- |<br>Note (by Dod):
- It is not documented in a help for GetFileAttributes, but it seems that
- under NT-based Windows systems, FALSE is always returned for files
- opened for excluseve use like pagefile.sys. }
- {$IFDEF _D3orHigher}
- function WFileExists( const FileName: WideString ) : Boolean;
- {* Returns True, if given file exists.
- |<br>Note (by Dod):
- It is not documented in a help for GetFileAttributes, but it seems that
- under NT-based Windows systems, FALSE is always returned for files
- opened for excluseve use like pagefile.sys. }
- {$ENDIF}
- function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;
- {* Changes current position in file. }
- {$IFDEF _D4orHigher}
- function FileFarSeek(Handle: THandle; MoveTo: Int64; MoveMethod: TMoveMethod): DWord;
- {* Changes current position in file. }
- {$ENDIF _D4orHigher}
- function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
- {* Reads bytes from current position in file to buffer. Returns number of
- read bytes. }
- {$IFDEF LIN}
- function GetFileSize( Handle: THandle; HiSize: PDWORD ): DWORD;
- {$ENDIF LIN}
- function File2Str(Handle: THandle): String;
- {* Reads file from current position to the end and returns result as ansi string. }
- {$IFNDEF _D2}
- function File2WStr(Handle: THandle): WideString;
- {* Reads file from current position to the end and returns result as unicode string. }
- {$ENDIF}
- function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
- {* Writes bytes from buffer to file from current position, extending its
- size if needed. }
- function FileEOF( Handle: THandle ) : Boolean;
- {* Returns True, if EOF is achieved during read operations or last byte is
- overwritten or append made to extend file during last write operation. }
- function FileFullPath( const FileName : KOLString ) : KOLString;
- {* Returns full path name for given file. Validness of source FileName path
- is not checked at all. }
- {$IFDEF WIN} //--------------- these functions have not sense in Linux: --------
- function FileShortPath( const FileName: KOLString ): KOLString;
- {* Returns short path to the file or directory. }
- function FileIconSystemIdx( const Path: KOLString ): Integer;
- {* Returns index of the index of the system icon correspondent to the file or
- directory in system icon image list. }
- function FileIconSysIdxOffline( const Path: KOLString ): Integer;
- {* The same as FileIconSystemIdx, but an icon is calculated for the file
- as it were offline (it is possible to get an icon for file even if
- it is not existing, on base of its extension only). }
- function DirIconSysIdxOffline( const Path: KOLString ): Integer;
- {* The same as FileIconSysIdxOffline, but for a folder rather then for a file. }
- {$ENDIF WIN} //-----------------------------------------------------------------
- procedure LogFileOutput( const filepath, str: String );
- {* Debug function. Use it to append given string to the end of the given file. }
-
- function StrSaveToFile( const Filename: KOLString; const Str: String ): Boolean;
- {* Saves a string to a file without any changes. If file does not exists, it is
- created. If it exists, it is overriden. If operation failed, FALSE is returned. }
- function StrLoadFromFile( const Filename: KOLString ): String;
- {* Reads entire file and returns its content as a string. If operation failed,
- an empty strinng is returned.
- |<br>by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
- read input from redirected console output. }
- {$IFNDEF _D2}
- function WStrSaveToFile( const Filename: KOLString; const Str: WideString ): Boolean;
- {* Saves a string to a file without any changes. If file does not exists, it is
- created. If it exists, it is overriden. If operation failed, FALSE is returned. }
- function WStrLoadFromFile( const Filename: KOLString ): WideString;
- {* Reads entire file and returns its content as a string. If operation failed,
- an empty strinng is returned.
- |<br>by Sergey Shishmintzev: it is possible to pass Filename = 'CON' to
- read input from redirected console output. }
- {$ENDIF}
-
- function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
- {* Saves memory block to a file (if file exists it is overriden, created new if
- not exists). }
- function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
- {* Loads file content to memory. }
-
- {$IFDEF WIN}
- type
- PFindFileData = ^TFindFileData;
- TFindFileData = {$ifndef wince}packed{$endif} record
- // from TWin32FindData: -------------
- dwFileAttributes: DWORD;
- ftCreationTime: TFileTime;
- ftLastAccessTime: TFileTime;
- ftLastWriteTime: TFileTime;
- nFileSizeHigh: DWORD;
- nFileSizeLow: DWORD;
- dwReserved0: DWORD;
- {$ifndef wince}dwReserved1: DWORD;{$endif}
- cFileName: array[0..MAX_PATH - 1] of KOLChar;
- {$ifndef wince}cAlternateFileName: array[0..13] of KOLChar;{$endif}
- //-------- + handle:
- FindHandle: THandle;
- end;
- {$ENDIF WIN}
- function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
- function Find_Next( var F: TFindFileData ): Boolean;
- procedure Find_Close( var F: TFindFileData );
- {$IFDEF _D2orD3}
- function FileSize( const Path: KOLString ) : Integer;
- {$ELSE}
- function FileSize( const Path: KOLString ) : Int64;
- {$ENDIF}
- {* Returns file size in bytes without opening it. If file too large
- to represent its size as Integer, -1 is returned. }
- procedure FileTime( const Path: KOLString;
- CreateTime, LastAccessTime, LastModifyTime: PFileTime );
- {* Returns file times without opening it. }
- function GetUniqueFilename( PathName: KOLstring ) : KOLString;
- {* If file given by PathName exists, modifies it to create unique
- filename in target folder and returns it. Modification is performed
- by incrementing last number in name (if name part of file does not
- represent a number, such number is generated and concatenated to
- it). E.g., if file aaa.aaa is already exist, the function checks
- names aaa1.aaa, aaa2.aaa, ..., aaa10.aaa, etc. For name abc123.ext,
- names abc124.ext, abc125.ext, etc. will be checked. }
- function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
- {* Compares time of file (createing, writing, accessing. Returns
- -1, 0, 1 if correspondantly FT1<FT2, FT1=FT2, FT1>FT2. }
- function DirectoryExists(const Name: KOLString): Boolean;
- {* Returns True if given directory (folder) exists. }
- function DiskPresent( const DrivePath: KOLString ): Boolean;
- {* Returns TRUE if the disk is present }
- {$IFDEF _D3orHigher}
- function WDirectoryExists(const Name: WideString): Boolean;
- {* }
- {$ENDIF}
- function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: String ): Boolean;
- {* Returns TRUE if directory does not contain files (or directories only)
- satisfying given mask. }
- function DirectoryEmpty(const Name: KOLString): Boolean;
- {* Returns True if given directory is not exists or empty. }
- //[Directory FUNCTIONS DECLARATIONS]
- function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
- {* Returns TRUE if given directory exists and has subdirectories. }
- function GetStartDir: KOLString;
- {* Returns path to directory where executable is located (regardless
- of current directory). }
- function ExePath: KOLString;
- {* Returns the path to the module (exe, dll) itself. }
-
-
-
- //---------------------------------------------------------
- // Following functions/procedures are created by Edward Aretino:
- // IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
- // ForceDirectories, CreateDir, ChangeFileExt
- //---------------------------------------------------------
- function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
- {* If S is finished with character C, it is excluded. }
- function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
- {* If S is not finished with character C, it is added. }
- function IncludeTrailingPathDelimiter(const S: KOLString): KOLstring;
- {* by Edward Aretino. Adds '\' to the end if it is not present. }
- function ExcludeTrailingPathDelimiter(const S: KOLString): KOLstring;
- {* by Edward Aretino. Removes '\' at the end if it is present. }
-
- function ExtractFileDrive( const Path: KOLString ) : KOLString;
- {* Returns only drive part from exact path to a file or a directory.
- For network paths, returns a computer name together with a following
- name of shared directory (like '\\compname\shared\' ). }
- function ExtractFilePath( const Path: KOLString ) : KOLString;
- {* Returns only path part from exact path to file. }
- {$IFDEF _D3orHigher}
- function WExtractFilePath( const Path: WideString ) : WideString;
- {* Returns only path part from exact path to file. }
- {$ENDIF}
- function IsNetworkPath( const Path: KOLString ): Boolean;
- {* Returns TRUE, if Path is starting from '\\'. }
- function ExtractFileName( const Path: KOLString ) : KOLString;
- {* Extracts file name from exact path to file. }
- function ExtractFileNameWOext( const Path: KOLString ) : KOLString;
- {* Extracts file name from path to file or from filename. }
- function ExtractFileExt( const Path: KOLString ) : KOLString;
- {* Extracts extention from file name (returns it with dot '.' first) }
- function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
- {* Returns Path to a file with extension replaced to a new extension.
- Pass a new extension started with '.', e.g. '.txt'. }
-
- function ForceDirectories(Dir: KOLString): Boolean;
- {* by Edward Aretino. Creates given directory if not present. All needed
- subdirectories are created if necessary. }
- function CreateDir(const Dir: KOLString): Boolean;
- {* by Edward Aretino. Creates given directory. }
- function ChangeFileExt(FileName: KOLString; const Extension: KOLstring): KOLstring;
- {* by Edward Aretino. Changes file extention. }
- function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
- {* Returns a path with extension replaced to a given one. }
- {$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- function ExtractShortPathName( const Path: KOLString ): KOLString;
- {* }
- {$IFDEF GDI}
- function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
- {* Returns shortened file path to fit MaxLen characters. }
- function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
- {* Returns shortened file path to fit MaxPixels for a given DC. If you pass
- Canvas.Handle of any control or bitmap object, ensure that font is valid
- for it (or call TCanvas.RequiredState( FontValid ) method before. If DC passed
- = 0, call is equivalent to call FilePathShortened, and MaxPixels means in such
- case maximum number of characters. }
- function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
- {* Exactly the same as MinimizeName in FileCtrl.pas (VCL). }
- {$ENDIF GDI}
-
- function GetSystemDir: KOLString;
- {* Returns path to windows system directory. }
- function GetWindowsDir : KOLstring;
- {* Returns path to Windows directory. }
- {$ENDIF WIN} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
- function GetWorkDir : KOLstring;
- {* Returns path to application's working directory. }
- function GetTempDir : KOLstring;
- {* Returns path to default temp folder (directory to place temporary files). }
- function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
- {* Returns path to just created temporary file. }
- function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLstring): KOLstring;
- {* List of files in string, separating each path from others with a character stored
- in FileOpSeparator variables (#13 by default).
- E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
- function DeleteFiles( const DirPath: KOLString ): Boolean;
- {* Deletes files by file mask (given with wildcards '*' and '?'). }
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- var FileOpSeparator: KOLChar = {$IFDEF OLD_COMPAT}';'{$ELSE}#13{$ENDIF};
- function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
- Title: PKOLChar): Boolean;
- {* By Unknown Mystic. FileOp can be: FO_MOVE, FO_COPY, FO_DELETE, FO_RENAME.
- Flags can be a combination of values: FOF_MULTIDESTFILES, FOF_CONFIRMMOUSE,
- FOF_SILENT, FOF_RENAMEONCOLLISION, FOF_NOCONFIRMATION, FOF_WANTMAPPINGHANDLE,
- FOF_ALLOWUNDO, FOF_FILESONLY, FOF_SIMPLEPROGRESS, FOF_NOCONFIRMMKDIR,
- FOF_NOERRORUI. Title used only with FOF_SIMPLEPROGRESS. }
- function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
- {* Deletes file to recycle bin. This operation can be very slow, when
- called for a single file. To delete group of files at once (fast),
- pass a list of paths to files to be deleted, separating each path
- from others with a character stored in FileOpSeparator variable (by default #13,
- but in case when OLD_COMPAT symbol added - ';'). E.g.: 'unit1.dcu'#13'unit1.~pa'
- |<br>
- FALSE is returned only in case when at least one file was not deleted
- successfully.
- |<br>
- Note, that files are deleted not to recycle bin, if wildcards are
- used or not fully qualified paths to files. }
- function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
- {* }
- {-}
- function DiskFreeSpace( const Path: KOLString ): I64; {+}
- {* Returns disk free space in bytes. Pass a path to root directory,
- e.g. 'C:\'.
- |<hr>
-
- <R Wrappers to registry API functions>
-
- These functions can be used independently to simplify access to Windows
- registry. }
- {$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[Registry FUNCTIONS DECLARATIONS]
- {++}(*
- function RegSetValueEx(hKey: HKEY; lpValueName: PChar;
- Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; {$ifdef wince}cdecl{$else}stdcall{$endif};
- *){--}
- function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
- {* Opens registry key for read operations (including enumerating of subkeys).
- Pass either handle of opened earlier key or one of constans
- HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS
- as a first parameter. If not successful, 0 is returned. }
- function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
- {* Opens registry key for write operations (including adding new values or
- subkeys), as well as for read operations too. See also RegKeyOpenRead. }
- function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
- {* Creates and opens key. }
- function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
- {* Reads key, which must have type REG_SZ (null-terminated string). If
- not successful, empty string is returned. This function as well as all
- other registry manipulation functions, does nothing, if Key passed is 0
- (without producing any error). }
- function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString ): KOLString;
- {* Like RegKeyGetStr, but accepts REG_EXPAND_SZ type, expanding all
- environment variables in resulting string.
- |<br>
- Code provided by neuron, e-mailto:neuron@hollowtube.mine.nu }
- function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
- {* Reads key value, which must have type REG_DWORD. If ValueName passed
- is '' (empty string), unnamed (default) value is reading. If not
- successful, 0 is returned. }
- function RegKeySetStr(Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
- {* Writes new key value as null-terminated string (type REG_SZ). If not
- successful, returns False. }
- function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
- expand: boolean): Boolean;
- {* Writes new key value as REG_SZ or REG_EXPAND_SZ. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
- function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
- {* Writes new key value as dword (with type REG_DWORD). Returns False,
- if not successful. }
- procedure RegKeyClose( Key: HKey );
- {* Closes key, opened using RegKeyOpenRead or RegKeyOpenWrite. (But does
- nothing, if Key passed is 0). }
- function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
- {* Deletes key. Does nothing if key passed is 0 (returns FALSE). }
- function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
- {* Deletes value. - by neuron, e-mailto:neuron@hollowtube.mine.nu }
- function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;
- {* Returns TRUE, if given subkey exists under given Key. }
- function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
- {* Returns TRUE, if given value exists under the Key.
- }
- function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
- {* Returns a size of value. This is a size of buffer needed to store
- registry key value. For string value, size returned is equal to a
- length of string plus 1 for terminated null character. }
- function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
- {* Reads binary data from a registry, writing it to the Buffer.
- It is supposed that size of Buffer provided is at least Count bytes.
- Returned value is actul count of bytes read from the registry and written
- to the Buffer.
- |<br>
- This function can be used to get data of any type from the registry, not
- only REG_BINARY. }
- function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
- {* Stores binary data in the registry. }
- function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
- {* Returns datetime variable stored in registry in binary format. }
- function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
- {* Stores DateTime variable in the registry. }
-
- //-------------------------------------------------------
- // registry functions by Valerian Luft <luft@valerian.de>
- //-------------------------------------------------------
- function RegKeyGetSubKeys( const Key: HKEY; List: PStrList): Boolean;
- {* The function enumerates subkeys of the specified open registry key.
- True is returned, if successful.
- }
- function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;
- {* The function enumerates value names of the specified open registry key.
- True is returned, if successful.
- }
- function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
- {* The function receives the type of data stored in the specified value.
- |<br>
- If the function fails, the return value is the Key value.
- |<br>
- If the function succeeds, the return value return will be one of the following:
- |<br>
- REG_BINARY , REG_DWORD, REG_DWORD_LITTLE_ENDIAN,
- REG_DWORD_BIG_ENDIAN, REG_EXPAND_SZ, REG_LINK , REG_MULTI_SZ,
- REG_NONE, REG_RESOURCE_LIST, REG_SZ
-
- |<hr>
-
- <R Data sorting (quicksort implementation)>
- This part contains implementation of 'quick sort' algorithm,
- based on following code:
-
- |<pre>
- | TQSort by Mike Junkin 10/19/95.
- | DoQSort routine adapted from Peter Szymiczek's QSort procedure which
- | was presented in issue#8 of The Unofficial Delphi Newsletter.
-
- | TQSort changed by Vladimir Kladov (Mr.Bonanzas) to allow 32-bit
- | sorting (of big arrays with more than 64K elements).
- |</pre>
-
- Finally, this sort procedure is adapted to XCL (and then to KOL)
- requirements (no references to SysUtils, Classes etc. TQSort object
- is transferred to a single procedure call and DoQSort method is
- renamed to SortData - which is a regular procedure now). }
-
- {$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
- //[Sorting TYPES]
- type
- TCompareEvent = function (const Data: Pointer; const e1,e2 : Dword) : Integer;
- {* Event type to define comparison function between two elements of an array.
- This event handler must return -1 or +1 (correspondently for cases e1<e2
- and e2>e2). Items are enumerated from 0 to uNElem. }
- TSwapEvent = procedure (const Data : Pointer; const e1,e2 : Dword);
- {* Event type to define swap procedure which is swapping two elements of an
- array. }
-
- //[SortData FUNCTIONS DECLARATIONS]
- procedure SortData( const Data: Pointer; const uNElem: Dword;
- const CompareFun: TCompareEvent;
- const SwapProc: TSwapEvent );
- {* Call it to sort any array of data of any kind, passing total
- number of items in an array and two defined (regular) function
- and procedure to perform custom compare and swap operations.
- First procedure parameter is to pass it to callback function
- CompareFun and procedure SwapProc. Items are enumerated from
- 0 to uNElem-1. }
-
- procedure SwapListItems( const L: Pointer; const e1, e2: DWORD );
- {* Use this function as the last parameter for SortData call when a PList
- object is sorting. SwapListItems just exchanges two items of the list. }
-
- procedure SortIntegerArray( var A : array of Integer );
- {* procedure to sort array of integers. }
-
- procedure SortDwordArray( var A : array of DWORD );
- {* Procedure to sort array of unsigned 32-bit integers.
- |<hr>
- }
- { -- directory list object -- }
- //[DirList Object]
-
- type
- TDirItemAction = ( diSkip, diAccept, diCancel );
- TOnDirItem = procedure( Sender: PObj; var DirItem: TFindFileData; var Accept: TDirItemAction )
- of object;
- TSortDirRules = ( sdrNone, sdrFoldersFirst, sdrCaseSensitive, sdrByName, sdrByExt,
- sdrBySize, sdrBySizeDescending, sdrByDateCreate, sdrByDateChanged,
- sdrByDateAccessed );
- {* List of rules (options) to sort directories. Rules are passed to Sort
- method in an array, and first placed rules are applied first. }
-
- {++}(*TDirList = class;*){--}
- PDirList = {-}^{+}TDirList;
- { ----------------------------------------------------------------------
- TDirList - Directory scanning
- ----------------------------------------------------------------------- }
- //[TDirList DEFINITION]
- TDirList = object( TObj )
- {* Allows easy directory scanning. This is not visual object, but
- storage to simplify working with directory content. }
- protected
- FList : PList;
- FPath: KOLString;
- fFilters: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
- fOnItem: TOnDirItem;
- function Get(Idx: Integer): PFindFileData;
- function GetCount: Integer;
- function GetNames(Idx: Integer): KOLString;
- function GetIsDirectory(Idx: Integer): Boolean;
- protected
- function SatisfyFilter( FileName : PKOLChar; FileAttr, FindAttr : DWord ) : Boolean;
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* Destructor. As usual, call Free method to destroy an object. }
- public
- property Items[ Idx : Integer ] : PFindfileData read Get; default;
- {* Full access to scanned items (files and subdirectories). }
- property IsDirectory[ Idx: Integer ]: Boolean read GetIsDirectory;
- {* Returns TRUE, if specified item represents a directory, not a file. }
- property Count : Integer read GetCount;
- {* Number of items. }
- property Names[ Idx : Integer ] : KOLString read GetNames;
- {* Full long names of directory items. }
- property Path : KOLString read FPath;
- {* Path of scanned directory. }
- procedure Clear;
- {* Call it to clear list of files. }
- procedure ScanDirectory( const DirPath, Filter : KOLString; Attr : DWord );
- {* Call it to rescan directory or to scan another directory content
- (method Clear is called first). Pass path to directory, file filter
- and attributes to scan directory immediately.
- |<br>
- Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
- parameter. If 0 passed, both files and directories are listed. }
- procedure ScanDirectoryEx( const DirPath, Filters : KOLString; Attr : DWord );
- {* Call it to rescan directory or to scan another directory content
- (method Clear is called first). Pass path to directory, file filter
- and attributes to scan directory immediately.
- |<br>
- Note: Pass FILE_ATTRIBUTE_... constants or-combination as Attr
- parameter. }
- procedure Sort( Rules : array of TSortDirRules );
- {* Sorts directory entries. If empty rules array passed, default rules
- array DefSortDirRules is used. }
- function FileList( const Separator {e.g.: ';', or #13}: KOLString;
- Dirs, FullPaths: Boolean ): KOLString;
- {* Returns a string containing all names separated with Separator.
- If Dirs=FALSE, only files are returned. }
- property OnItem: TOnDirItem read fOnItem write fOnItem;
- {* This event is called on reading each item while scanning directory.
- To use it, first create PDirList object with empty path to scan, then
- assign OnItem event and call ScanDirectory with correct path. }
- end;
- //[END OF TDirList DEFINITION]
-
- //[NewDirList DECLARATIONS]
- function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
- {* Creates directory list object using easy one-string filter. If Attr = FILE_ATTRIBUTE_NORMAL,
- only files are scanned without directories. If Attr = 0, both files and
- directories are listed. }
-
- function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
- {* Creates directory list object using several filters, separated by ';'.
- Filters starting from '^' consider to be anti-filters, i.e. files,
- satisfying to those masks, are skept during scanning. }
-
- const DefSortDirRules : array[ 0..3 ] of TSortDirRules = ( sdrFoldersFirst,
- sdrByName, sdrBySize, sdrByDateCreate );
- {* Default rules to sort directory entries. }
-
- //[DirectorySize DECLARATION]
- {-}
- function DirectorySize( const Path: KOLString ): I64;
- {* Returns directory size in bytes as large 64 bit integer. }
- {+}
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[OpenSaveDialog OPTIONS]
- type
- TOpenSaveOption = ( OSCreatePrompt,
- OSExtensionDiffent,
- OSFileMustExist,
- OSHideReadonly,
- OSNoChangedir,
- OSNoReferenceLinks,
- OSAllowMultiSelect,
- OSNoNetworkButton,
- OSNoReadonlyReturn,
- OSOverwritePrompt,
- OSPathMustExist,
- OSReadonly,
- OSNoValidate
- //{$IFDEF OpenSaveDialog_Extended}
- ,
- OSTemplate,
- OSHook
- //{$ENDIF}
- );
- TOpenSaveOptions = set of TOpenSaveOption;
- {* Options available for TOpenSaveDialog. }
-
- {++}(*TOpenSaveDialog = class;*){--}
- POpenSaveDialog = {-}^{+}TOpenSaveDialog;
- { ----------------------------------------------------------------------
- TOpenSaveDialog
- ----------------------------------------------------------------------- }
- //[TOpenSaveDialog DEFINITION]
- TOpenSaveDialog = object( TObj )
- {* Object to show standard Open/Save dialog. Initially provided
- for XCL by Carlo Kok. }
- protected
- FFilter : KOLString;
- fFilterIndex : Integer;
- fOpenDialog : Boolean;
- FInitialDir : KOLString;
- FDefExtension : KOLString;
- FFilename : KOLString;
- FTitle : KOLString;
- FOptions : TOpenSaveOptions;
- fWnd: THandle;
- fOpenReadOnly: Boolean;
- public
- TemplateName: KOLString; // do not forget to add OpenSaveDialog_Extended
- HookProc: Pointer; // to project options conditionals!
- NoPlaceBar: Boolean; // TRUE, if place bar is disabled in the new style
- // dialogs (if the symbol OpenSaveDialog_Extended is
- // not added in project options, place bar is always
- // enabled in Windows 2000 and higher).
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* destructor }
- Function Execute : Boolean;
- {* Call it after creating to perform selecting of file by user. }
- property Filename : KOLString read FFilename write FFileName;
- {*
- Filename is separated by #13 when multiselect is true and the first
- file, is the path of the files selected.
- |<pre>
- | C:\Projects
- | Test1.Dpr
- | Test2.Dpr
- |</pre>
- If only one file is selected, it is provided as (e.g.)
- C:\Projects\Test1.dpr
- |<br> For case when OSAllowMultiselect option used, after each
- call initial value for a Filename containing several files prevents
- system from opening the dialog. To fix this, assign another initial
- value to Filename property in your code, when you use multiselect.
- }
- property InitialDir : KOLString read FInitialDir write FInitialDir;
- {* Initial directory path. If not set, current directory (usually
- directory when program is started) is used. }
- property Filter : KOLString read FFilter write FFilter;
- {* A list of pairs of filter names and filter masks, separated with '|'.
- If a mask contains more than one mask, it should be separated with ';'.
- E.g.:
- ! 'All files|*.*|Text files|*.txt;*.1st;*.diz' }
- property FilterIndex : Integer read FFilterIndex write FFilterIndex;
- {* Index of default filter mask (0 by default, which means "first"). }
- property OpenDialog : Boolean read FOpenDialog write FOpenDialog;
- {* True, if "Open" dialog. False, if "Save" dialog. True is default. }
- property Title : KOLString read Ftitle write Ftitle;
- {* Title for dialog. }
- property Options : TOpenSaveOptions read FOptions write FOptions;
- {* Options. }
- property DefExtension : KOLString read FDefExtension write FDefExtension;
- {* Default extention. Set it to desired extension without leading period,
- e.g. 'txt', but not '.txt'. }
- property WndOwner: THandle read fWnd write fWnd;
- {* Owner window handle. If not assigned, Applet.Handle is used (whenever
- possible). Assign it, if your application has stay-on-top forms, and
- a separate Applet object is used. }
- property OpenReadOnly: Boolean read fOpenReadOnly;
- {* TRUE after Execute, if Read Only check box was checked by the user.
- Options are not affected anyway. }
- end;
- //[END OF TOpenSaveDialog DEFINITION]
-
- //[Default OpenSaveDialog OPTIONS]
- const DefOpenSaveDlgOptions: TOpenSaveOptions = [ OSHideReadonly,
- OSOverwritePrompt, OSFileMustExist, OSPathMustExist ];
-
- //[NewOpenSaveDialog DECLARATION]
- function NewOpenSaveDialog( const Title, StrtDir: KOLString;
- Options: TOpenSaveOptions ): POpenSaveDialog;
- {* Creates object, which can be used (several times) to open file(s)
- selecting dialog. }
-
- //[OpenDirectory Object]
- type
- {++}(*TOpenDirDialog = class;*){--}
- POpenDirDialog = {-}^{+}TOpenDirDialog;
-
- TOpenDirOption = ( odBrowseForComputer, odBrowseForPrinter, odDontGoBelowDomain,
- odOnlyFileSystemAncestors, odOnlySystemDirs, odStatusText,
- odBrowseIncludeFiles, odEditBox, odNewDialogStyle );
- {* Flags available for TOpenDirDialog object. }
- // odfStatusText - do not support status callback
- TOpenDirOptions = set of TOpenDirOption;
- {* Set of all flags used to control ZOpenDirDialog class. }
-
- TOnODSelChange = procedure( Sender: POpenDirDialog; NewSelDir: PKOL_Char;
- var EnableOK: Integer; var StatusText: KOL_String )
- of object;
- {* Event type to be called when user select another directory in OpenDirDialog.
- Set EnableOK to -1 to disable OK button, or to +1 to enable it.
- It is also possible to set new StatusText string. }
-
- {$ifdef wince}
- {$define read_interface}
- {$I KOLCEOpenDir.inc}
- {$undef read_interface}
- {$else}
- { ----------------------------------------------------------------------
- TOpenDirDialog
- ----------------------------------------------------------------------- }
- //[TOpenDirDialog DEFINITION]
- TOpenDirDialog = object( TObj )
- {* Dialog for open directories, uses SHBrowseForFolder. }
- protected
- FTitle: KOLString;
- FOptions: TOpenDirOptions;
- FCallBack: Pointer;
- FCenterProc: procedure( Wnd: HWnd );
- FBuf : array[ 0..MAX_PATH ] of KOLChar;
- FInitialPath: String;
- FCenterOnScreen: Boolean;
- FDoSelChanged: procedure( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ); {$ifdef wince}cdecl{$else}stdcall{$endif};
- FOnSelChanged: TOnODSelChange;
- FStatusText: KOLString;
- FWnd, FDialogWnd: HWnd;
- function GetPath: KOLString;
- procedure SetInitialPath(const Value: KOLString);
- procedure SetCenterOnScreen(const Value: Boolean);
- procedure SetOnSelChanged(const Value: TOnODSelChange);
- function GetInitialPath: KOLString;
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* destructor }
- function Execute : Boolean;
- {* Call it to select directory by user. Returns True, if operation was
- not cancelled by user. }
- property Title : KOLString read FTitle write FTitle;
- {* Title for a dialog. }
- property Options : TOpenDirOptions read FOptions write FOptions;
- {* Option flags. }
- property Path : KOLString read GetPath;
- {* Resulting (selected by user) path. }
- property InitialPath: KOLString read GetInitialPath write SetInitialPath;
- {* Set this property to a path of directory to be selected initially
- in a dialog. }
- property CenterOnScreen: Boolean read FCenterOnScreen write SetCenterOnScreen;
- {* Set it to True to center dialog on screen. }
- property OnSelChanged: TOnODSelChange read FOnSelChanged write SetOnSelChanged;
- {* This event is called every time, when user selects another directory.
- It is possible to enable/disable OK button in dialog and/or change
- dialog status text in responce to event. }
- property WndOwner: HWnd read FWnd write FWnd;
- {* Owner window. If you want to provide your dialog visible over stay-on-top
- form, fire it as a child of the form, assigning the handle of form window
- to this property first. }
- property DialogWnd: HWnd read FDialogWnd;
- {* Handle to the open directory dialog itself, become available on the
- first call of callback procedure (i.e. on the first call to OnSelChanged).
- }
- end;
- //[END OF TOpenDirDialog DEFINITION]
- {$endif wince}
-
- //[NewOpenSaveDialog DECLARATION]
- function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
- POpenDirDialog;
- {* Creates object, which can be used (several times) to open directory
- selecting dialog (using SHBrowseForFolder API call). }
-
- //[Color Dialog Object]
- type
- TColorCustomOption = ( ccoFullOpen, ccoShortOpen, ccoPreventFullOpen );
-
- type TKOLOpenDirDialog = POpenDirDialog;
-
- {++}(*TColorDialog = class;*){--}
- PColorDialog = {-}^{+}TColorDialog;
- { ----------------------------------------------------------------------
- TColorDialog
- ----------------------------------------------------------------------- }
- //[TColorDialog DEFINITION]
- TColorDialog = object( TObj )
- {* Color choosing dialog. }
- protected
- public
- OwnerWindow: HWnd;
- {* Owner window (can be 0). }
- CustomColors: array[ 1..16 ] of TColor;
- {* Array of stored custom colors. }
- ColorCustomOption: TColorCustomOption;
- {* Options (how to open a dialog). }
- Color: TColor;
- {* Returned color (if the result of Execute is True). }
- function Execute: Boolean;
- {* Call this method to open a dialog and wait its result. }
- end;
- //[END OF TColorDialog DEFINITION]
-
- //[NewColorDialog DECLARATION]
- function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
- {* Creates color choosing dialog object. }
- {$ENDIF WIN_GDI}
- {$IFDEF WIN_GDI}
- //[Ini files]
- type
- TIniFileMode = ( ifmRead, ifmWrite );
- {* ifmRead is default mode (means "read" data from ini-file.
- Set mode to ifmWrite to write data to ini-file, correspondent to
- TIniFile. }
- {$ifdef wince}
- {$define read_interface}
- {$I KOLCE_IniFile.inc}
- {$undef read_interface}
- {$else}
- {++}(*TIniFile = class;*){--}
- PIniFile = {-}^{+}TIniFile;
- { ----------------------------------------------------------------------
- TIniFile - store/load data to ini-files
- ----------------------------------------------------------------------- }
- //[TIniFile DEFINITION]
- TIniFile = object( TObj )
- {* Ini file incapsulation. The main feature is what the same block of
- read-write operations could be defined (difference must be only in
- Mode value).
- |*Ini file sample.
- This sample shows how the same Pascal operators can be used both
- for read and write for the same variables, when working with TIniFile:
- ! procedure ReadWriteIni( Write: Boolean );
- ! var Ini: PIniFile;
- ! begin
- ! Ini := OpenIniFile( 'MyIniFile.ini' );
- ! Ini.Section := 'Main';
- ! if Write then // if Write, the same operators will save
- ! Ini.Mode := ifmWrite; // data rather then load.
- ! MyForm.Left := Ini.ValueInteger( 'Left', MyForm.Left );
- ! MyForm.Top := Ini.ValueInteger( 'Top', MyForm.Top );
- ! Ini.Free;
- ! end;
- !
- |* }
- protected
- fMode: TIniFileMode;
- fFileName: KOLString;
- fSection: KOLString;
- protected
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* destructor }
- property Mode: TIniFileMode read fMode write fMode;
- {* ifmWrite, if write data to ini-file rather than read it. }
- property FileName: KOLString read fFileName;
- {* Ini file name. }
- property Section: KOLString read fSection write fSection;
- {* Current ini section. }
- function ValueInteger( const Key: KOLString; Value: Integer ): Integer;
- {* Reads or writes integer data value. }
- function ValueString( const Key: KOLString; const Value: KOLString ): KOLString;
- {* Reads or writes string data value. }
- function ValueBoolean( const Key: KOLString; Value: Boolean ): Boolean;
- {* Reads or writes boolean data value. }
- function ValueData( const Key: KOLString; Value: Pointer; Count: Integer ): Boolean;
- {* Reads or writes data from/to buffer. Returns True, if success. }
- procedure ClearAll;
- {* Clears all sections of ini-file. }
- procedure ClearSection;
- {* Clears current Section of ini-file. }
- procedure ClearKey( const Key: KOLString );
- {* Clears given key in current section. }
-
- /////////////// + by Vyacheslav A. Gavrik:
- {$IFDEF UNICODE_CTRLS}
- procedure GetSectionNames(Names:PWStrList);
- {$ELSE}
- procedure GetSectionNames(Names:PStrList);
- {$ENDIF}
- {* Retrieves section names, storing it in string list passed as a parameter.
- String list does not cleared before processing. Section names are added
- to the end of the string list. }
- {$IFDEF UNICODE_CTRLS}
- procedure SectionData(Names:PWStrList);
- {$ELSE}
- procedure SectionData(Names:PStrList);
- {$ENDIF}
- {* Read/write current section content to/from string list. (Depending on
- current Mode value). }
- ///////////////
-
- end;
- //[END OF TIniFile DEFINITION]
- {$endif wince}
- //[OpenIniFile DECLARATION]
- function OpenIniFile( const FileName: KOLString ): PIniFile;
- {* Opens ini file, creating TIniFile object instance to work with it. }
-
- {$ENDIF WIN_GDI}
- //[MENU OBJECT]
- {$ifdef win32}
- {$ifndef FPC}
- type
- TMenuitemInfo = {$ifndef wince}packed{$endif} record
- cbSize: UINT;
- fMask: UINT;
- fType: UINT; { used if MIIM_TYPE}
- fState: UINT; { used if MIIM_STATE}
- wID: UINT; { used if MIIM_ID}
- hSubMenu: HMENU; { used if MIIM_SUBMENU}
- hbmpChecked: HBITMAP; { used if MIIM_CHECKMARKS}
- hbmpUnchecked: HBITMAP; { used if MIIM_CHECKMARKS}
- dwItemData: DWORD; { used if MIIM_DATA}
- dwTypeData: PKOLChar; { used if MIIM_TYPE}
- cch: UINT; { used if MIIM_TYPE}
- hbmpItem: HBITMAP; { used if MIIM_BITMAP - not exists under Windows95 }
- end;
- {$endif FPC}
- {$endif win32}
-
- const
- TPM_HORPOSANIMATION = $0400;
- TPM_HORNEGANIMATION = $0800;
- TPM_VERPOSANIMATION = $1000;
- TPM_VERNEGANIMATION = $2000;
- TPM_NOANIMATION = $4000;
-
- type
- {++}(*TMenu = class;*){--}
- PMenu = {-}^{+}TMenu;
-
- TOnMenuItem = procedure( Sender : PMenu; Item : Integer ) of object;
- {* Event type to define OnMenuItem event. }
-
- TMenuAccelerator = {$ifndef wince}packed{$endif} Record
- {* Menu accelerator record. Use MakeAccelerator function to combine desired
- attributes into a record, describing the accelerator. }
- fVirt: Byte; // or-combination of FSHIFT, FCONTROL, FALT, FVIRTKEY, FNOINVERT
- Key: Word; // character or virtual key code (FVIRTKEY flag is present above)
- NotUsed: Byte; // not used
- end;
-
- // by Sergey Shisminzev:
- TMenuOption = (moDefault, moDisabled, moChecked,
- moCheckMark, moRadioMark, moSeparator, moBitmap, moSubMenu,
- moBreak, moBarBreak);
- {* Options to add menu items dynamically. }
- TMenuOptions = set of TMenuOption;
- {* Set of options for menu item to use it in TMenu.AddItem method. }
-
- TMenuBreak = ( mbrNone, mbrBreak, mbrBarBreak );
- {* Possible menu item break types. }
-
- { ----------------------------------------------------------------------
- TMenu - main, popup menu and menu item
- ----------------------------------------------------------------------- }
- //[TMenu DEFINITION]
- TMenu = object( TObj )
- protected
- {$IFDEF GDI}
- function GetItemHelpContext(Idx: Integer): Integer;
- procedure SetItemHelpContext(Idx: Integer; const Value: Integer);
- {* Dynamic menu incapsulation object. Can play role of form main menu or popup
- menu, depending on kind of parent window (form or control) and order of
- creation (created first (for a form) become main menu). Does not allow
- merging menus, but items can be hidden. Additionally checkmark bitmaps,
- shortcut key accelerators and other features are available. }
- protected
- FHandle: HMenu;
- FId: Integer;
- FControl: PControl;
- {$ENDIF GDI}
- fNextMenu : PMenu;
- {$IFDEF GDI}
- FMenuBreak: TMenuBreak;
- FOnMenuItem : TOnMenuItem;
- FOnRadioOff : TOnMenuItem;
- fOnPopup: TOnEvent;
- fByAccel: Boolean;
- FPopupFlags: DWORD;
- //fAutoPopup: Boolean;
- FSavedState: DWORD;
- FData: Pointer;
- FOwnerDraw: Boolean;
- {$ENDIF GDI}
- FParentMenu: PMenu;
- FItems: PList;
- FRadioGroup: Integer;
- FIsCheckItem: Boolean;
- FIsSeparator: Boolean;
- FVisible: Boolean;
- FCaption: KOLString;
- {$IFDEF _X_}
- {$IFDEF GTK}
- fChecked: Boolean;
- fMnemonics: String;
- fGtkMenuItem: PGtkWidget;
- fGtkMenuShell: PGtkWidget;
- fGtkMenuBar: PGtkWidget;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF GDI}
- FBitmap: HBitmap;
- FBmpChecked: HBitmap;
- FBmpItem: HBitmap;
- ClearBitmapsProc: procedure( Sender: PMenu );
- FClearBitmaps: Boolean;
- FNotPopup: Boolean;
- FAccelerator: TMenuAccelerator;
- FHelpContext: Integer;
- FOnMeasureItem: TOnMeasureItem;
- FOnDrawItem: TOnDrawItem;
- {$IFDEF USE_MENU_CURCTL}
- fCurCtl: PControl;
- {$ENDIF USE_MENU_CURCTL}
- function GetItems( Id: HMenu ): PMenu;
- function GetCount: Integer;
- function GetTopParent: PMenu;
- function GetState( const Index: Integer ): Boolean;
- procedure SetState( const Index: Integer; Value: Boolean );
- procedure SetVisible( Value: Boolean );
- procedure SetData( Value: Pointer );
- procedure SetMenuItemCaption( const Value: KOLString );
- function FillMenuItems(AHandle: HMenu; StartIdx: Integer;
- const Template: array of PKOLChar): Integer;
- procedure SetMenuBreak( Value: TMenuBreak );
- function GetControl: PControl;
- function GetInfo( var MII: TMenuItemInfo ): Boolean;
- function SetInfo( var MII: TMenuItemInfo ): Boolean;
- function SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
- procedure SetBitmap( Value: HBitmap );
- procedure SetBmpChecked( Value: HBitmap );
- procedure SetBmpItem( Value: HBitmap );
- procedure ClearBitmaps;
- procedure SetAccelerator( const Value: TMenuAccelerator );
- {$IFDEF GDI}
- procedure SetHelpContext( Value: Integer );
- {$ENDIF GDI}
- procedure SetSubmenu( Value: HMenu );
- procedure SetOnMeasureItem( const Value: TOnMeasureItem );
- procedure SetOnDrawItem( const Value: TOnDrawItem );
- procedure SetOwnerDraw( Value: Boolean );
- protected
- function GetItemChecked( Item : Integer ) : Boolean;
- procedure SetItemChecked( Item : Integer; Value : Boolean );
- function GetItemBitmap(Idx: Integer): HBitmap;
- procedure SetItemBitmap(Idx: Integer; const Value: HBitmap);
- function GetItemText(Idx: Integer): KOLString;
- procedure SetItemText(Idx: Integer; const Value: KOLString);
- function GetItemEnabled(Idx: Integer): Boolean;
- procedure SetItemEnabled(Idx: Integer; const Value: Boolean);
- function GetItemVisible(Idx: Integer): Boolean;
- procedure SetItemVisible(Idx: Integer; const Value: Boolean);
- function GetItemAccelerator(Idx: Integer): TMenuAccelerator;
- procedure SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
- function GetItemSubMenu( Idx: Integer ): HMenu;
- {$ENDIF GDI}
- {$ifdef wince}
- procedure ReCreate;
- procedure SaveState;
- {$endif wince}
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* To release menu dynamically, call Free method instead. All (popup)
- menus created after this (for the same control) are destroyed in
- that case too.
- |<br>
- It is not necessary to release menu object manually: all menus,
- created with given form (or control), are automatically released,
- when owner form (or control) is destroyed.
- }
- {$IFDEF GDI}
- property Handle : HMenu read FHandle;
- {* Handle of Windows menu object. }
- property MenuId: Integer read FId;
- {* Id of the menu item object. If menu item has subitems, it has
- also submenu Handle. Top parent menu object itself has no Id.
- Id-s areassigned automatically starting from 4096. Do not
- (re)create menu items instantly, because such values are not
- reused, and maximum possible Id value must not exceed 65535. }
- property Parent: PMenu read FParentMenu;
- {* Parent menu item (or parent menu). }
- property TopParent: PMenu read GetTopParent;
- {* Top parent menu, owning all nested subitems. }
- property Owner: PControl read GetControl;
- {* Parent control or form. }
- property Caption: KOLString read FCaption write SetMenuItemCaption;
- {* Menu item caption text (including '&' indicating mnemonic characters,
- and keyboard accelerator representation string, usually following
- tabulation character). }
- property Items[ Id: HMenu ]: PMenu read GetItems;
- {* Returns menu item object by its index or by menu id. Since menu id
- values are starting from 4096, values from 0 to 4095 are interpreted
- as absolute index of menu item. Be careful accessing menu items or
- submenus by index, if you dynamically insert or delete items or
- submenus. In this version, separators are enumerating too, like
- all other items. Use index -1 to access object itself. The first
- item of a menu (or the first subitem of submenu item) has index 0.
- Children are enumerating before all siblings. The maximum available
- index is (Count - 1), when accessing menu items by index. }
- property Count: Integer read GetCount;
- {* Count of items together with all its nested subitems. }
- function IndexOf( Item: PMenu ): Integer;
- {* Returns index of an item. This index can be used to access
- menu item. Value -2 is returned, if the Item is not a child for menu
- or menu item, and has no parents, which are children for it, etc.
- Menu object itself always has index -1. }
- property OnMenuItem : TOnMenuItem read FOnMenuItem write FOnMenuItem;
- {* Is called when menu item is clicked. Absolute index of menu item
- clicked is passed as the second parameter. TopParent always is
- passed as a Sender parameter. }
- property ByAccel: Boolean read fByAccel;
- {* True, when OnMenuItem is called not by mouse, but by accelerator key.
- Check this flag for entire menu (TopParent), not for item itself.
- (Note, that Sender in OnMenuItem always is TopParent menu object). )
- }
- property IsSeparator: Boolean read FIsSeparator;
- {* TRUE, if a separator menu item. }
- property MenuBreak: TMenuBreak read FMenuBreak write SetMenuBreak;
- {* Menu item break type. }
- property OnUncheckRadioItem : TOnMenuItem read FOnRadioOff write FOnRadioOff;
- {* Is called when radio item becomes unchecked in menu in result of
- checking another radio item of the same radio group. }
- property RadioGroup: Integer read FRadioGroup write FRadioGroup;
- {* Radio group index. Several neighbour items with the same radio group
- index form radio group. Only single item from the same group can be
- checked at a time. }
- property IsCheckItem: Boolean read FIsCheckItem;
- {* If menu item is defined as check item, it is checked automatically
- when clicked. }
- procedure RadioCheckItem;
- {* Call this method to check radio item. (Calling this method for
- an item, which is not belonging to a radio group, just sets its
- Checked state to TRUE). }
- property Checked: Boolean index MFS_CHECKED read GetState write SetState;
- {* Checked state of the item. }
- property Enabled: Boolean
- {$IFDEF F_P}
- index $80000000 or MFS_DISABLED
- {$ELSE DELPHI}
- index Integer( $80000000 or MFS_DISABLED )
- {$ENDIF F_P/DELPHI}
- read GetState write SetState;
- {* Enabled state of the item. Whaen assigned, Grayed state also is
- set to arbitrary value (i.e., when Enabled is set to true, Grayed
- is set to FALSE. }
- property DefaultItem: Boolean index MFS_DEFAULT read GetState write SetState;
- {* Set this property to TRUE to make menu item default. Default item
- is drawn with bold.
- |<br>If you change DefaultItem at run-time and whant
- to provide changing its visual state, recreate the item first resetting
- Visible property, then setting it again. }
- property Highlight: Boolean index MFS_HILITE read GetState write SetState;
- {* Highlight state of the item. }
- property Visible: Boolean read FVisible write SetVisible;
- {* Visibility of menu item. }
- property Data: Pointer read FData write SetData;
- {* Data pointer, associated with the menu item. }
- property Bitmap: HBitmap read FBitmap write SetBitmap;
- {* Bitmap used for unchecked state of the menu item. }
- property BitmapChecked: HBitmap read FBmpChecked write SetBmpChecked;
- {* Bitmap used for checked state of the menu item. }
- property BitmapItem: HBitmap read FBmpItem write SetBmpItem;
- {* Bitmap used for item itself. In addition, following special values
- are possible:
- HBMMENU_CALLBACK, HBMMENU_MBAR_CLOSE, HBMMENU_MBAR_CLOSE_D,
- HBMMENU_MBAR_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D, HBMMENU_MBAR_RESTORE,
- HBMMENU_POPUP_CLOSE, HBMMENU_POPUP_MAXIMIZE, HBMMENU_POPUP_MINIMIZE,
- HBMMENU_POPUP_RESTORE, HBMMENU_SYSTEM. }
- property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
- {* Accelerator for menu item. }
- {$IFDEF GDI}
- property HelpContext: Integer read FHelpContext write SetHelpContext;
- {* Help context for entire menu (help context can not be assigned to
- individual menu items). }
- {$ENDIF GDI}
-
- procedure AssignEvents( StartIdx: Integer; const Events: array of TOnMenuItem );
- {* It is possible to assign its own event handler to every menu item
- using this call. This procedure also is called automatically in
- a constructor NewMenuEx. }
-
- function Popup( X, Y : Integer ): Integer; {!ecm}
- {* Only for popup menu - to popup it at the given position on screen.
- Return: If you specify TPM_RETURNCMD in the uFlags parameter, the return
- value is the menu-item identifier of the item that the user selected.
- If the user cancels the menu without making a selection, or if an error
- occurs, then the return value is zero.
- If you do not specify TPM_RETURNCMD in the uFlags parameter, the return
- value is nonzero if the function succeeds and zero if it fails. }
- function PopupEx( X, Y: Integer ): Integer; {!ecm}
- {* This version of popup command is very useful, when popup menu is activated
- when its parent window is not visible (e.g., for a kind of applications,
- which always are invisible, and can be activated only using tray icon).
- PopupEx method provides correct tracking of menu disappearing when mouse
- is clicked anywhere else on screen, fixing strange menu behavior in some
- Windows versions (NT).
- |<br>
- Actually, when PopupEx used, parent form is shown but below of visible
- screen, and when menu is disappearing, previous state of the form (visibility
- and position) are restored. If such solvation is not satisfying You,
- You can do something else (e.g., use region clipping, etc.) }
- property OnPopup: TOnEvent read fOnPopup write fOnPopup;
- {* This event occurs before the popup menu is shown. }
- property NotPopup: Boolean read FNotPopup write FNotPopup;
- {* Set this property to true to prevent popup of popup menu, e.g. in
- OnPopup event handler. }
- property Flags: DWORD read FPopupFlags write FPopupFlags;
- {* Pop-up flags, which are used to call TrackPopupMenuEx, when Popup or
- PopupEx method is called. Can be a combination of following values:
- |<br>
- TPM_CENTERALIGN or TPM_LEFTALIGN or TPM_RIGHTALIGN
- |<br>
- TPM_BOTTOMALIGN or TPM_TOPALIGN or TPM_VCENTERALIGN
- |<br>
- TPM_NONOTIFY or TPM_RETURNCMD
- |<br>
- TPM_LEFTBUTTON or TPM_RIGHTBUTTON
- |<br>
- TPM_HORNEGANIMATION or TPM_HORPOSANIMATION or TPM_NOANIMATION or
- TPM_VERNEGANIMATION or TPM_VERPOSANIMATION
- |<br>
- TPM_HORIZONTAL or TPM_VERTICAL.
- |<br>
- By default, a combination TPM_LEFTALIGN or TPM_LEFTBUTTON is used. }
- function Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
- Options: TMenuOptions): PMenu;
- {* Inserts new menu item before item, given by Id (>=4096) or index
- value InsertBefore. Pointer to an object created is returned. }
- property SubMenu: HMenu read FHandle; // write SetSubMenu;
- {* Submenu associated with the menu item. The same as Handle. It was possible
- in ealier versions to change this value, replacing (removing, assigning)
- entire popup menu as a submenu for menu item.
- But in modern version of TMenu, this is not possible.
- Instead, entire menu object should be added or removed using
- InsertSubmenu or RemoveSubmenu methods. }
- procedure InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
- {* Inserts existing menu item (together with its subitems if any present)
- into given position. See also RemoveSubMenu. }
- function RemoveSubMenu( ItemToRemove: Integer ): PMenu;
- {* Removes menu item from the menu, returning TMenu object, representing it,
- if submenu item, having its own children, detached. If an individual menu
- item is removed, nil is returned.
- This function can be useful to add or remove dynamically entire submenus
- (created together with its subitems). }
- property OnMeasureItem: TOnMeasureItem read FOnMeasureItem write SetOnMeasureItem;
- {* This event is called for owner-drawn menu items. Event handler should return
- menu item height in lower word of a result and item width (for menu) in
- high word of result. If either for height or for width returned value is 0,
- a default one is used. }
- property OnDrawItem: TOnDrawItem read FOnDrawItem write SetOnDrawItem;
- {* This event is called for owner-drawn menu items. }
- property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw;
- {* Set this property to true for some items to make it owner-draw. }
-
- // For compatibility with old code (be sure that item with given index
- // actually exists):
- function GetMenuItemHandle( Idx : Integer ): DWORD;
- {* Returns Id of menu item with given index. }
- property ItemHandle[ Idx: Integer ]: DWORD read GetMenuItemHandle;
- {* Returns handle for item given by index. }
- property ItemChecked[ Idx : Integer ] : Boolean read GetItemChecked write SetItemChecked;
- {* True, if correspondent menu item is checked. }
- procedure RadioCheck( Idx : Integer );
- {* Call this method to check radio item. For radio items, do not
- use assignment to ItemChecked or Checked properties. }
- property ItemBitmap[ Idx: Integer ]: HBitmap read GetItemBitmap write SetItemBitmap;
- {* This property allows to assign bitmap to menu item (for unchecked state
- only - for checked menu items default checkmark bitmap is used). }
- procedure AssignBitmaps( StartIdx: Integer; Bitmaps: array of HBitmap );
- {* Can be used to assign bitmaps to several menu items during one call. }
- property ItemText[ Idx: Integer ]: KOLString read GetItemText write SetItemText;
- {* This property allows to get / modify menu item text at run time. }
- property ItemEnabled[ Idx: Integer ]: Boolean read GetItemEnabled write SetItemEnabled;
- {* Controls enabling / disabling menu items. Disabled menu items are
- displayed (grayed) but inaccessible to click. }
- property ItemVisible[ Idx: Integer ]: Boolean read GetItemVisible write SetItemVisible;
- {* This property allows to simulate visibility of menu items (implementing
- it by removing or inserting again if needed. For items of submenu, which
- is made invisible, True is returned. If such item made Visible, entire
- submenu with all its parent menu items becomes visible. To release menu
- properly it is necessary to make before all its items visible again.
- This does not matter, if menu is released at the end of execution, but
- can be sensible if owner form is destroyed and re-created at run time
- dynamically. }
- property ItemHelpContext[ Idx: Integer ]: Integer read GetItemHelpContext
- write SetItemHelpContext;
- function ParentItem( Idx: Integer ): Integer;
- {* Returns index of parent menu item (for submenu item). If there are no
- such item (Idx corresponds to root level menu item), -1 is returned. }
- property ItemAccelerator[ Idx: Integer ]: TMenuAccelerator read GetItemAccelerator write SetItemAccelerator;
- {* Allows to get / change accelerator key kodes assigned to menu items.
- Has no effect unless SupportMnemonics called for a form. }
- property ItemSubmenu[ Idx: Integer ]: HMenu read GetItemSubmenu; // write SetItemSubmenu;
- {* Retrieves submenu item dynamically. See also SubMenu property. }
-
- // by Sergey Shisminzev:
- function AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
- {* Adds menu item dynamically. Returns ID of the added item. }
- function InsertItem(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
- {* Inserts menu item before an item with ID, given by InsertBefore parameter. }
- function InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions;
- ByPosition: Boolean): Integer;
- {* Inserts menu item by command or by position, dependant on ByPosition parameter }
- procedure RedrawFormMenuBar;
- {* }
-
- {$IFDEF USE_MENU_CURCTL}
- property CurCtl: PControl read fCurCtl write fCurCtl;
- {* By Alexander Pravdin. This property is assigned to a control which were
- initiated a pop-up, for popup menu. }
- {$ENDIF USE_MENU_CURCTL}
- {$ENDIF GDI}
- end;
- //[END OF TMenu DEFINITION]
-
- {$IFDEF WIN_GDI}
- //[MenuStructSize VARIABLE]
- function MenuStructSize: Integer;
- {* Returns 44 under Windows95, and 48 (=sizeof(TMenuItemInfo) under all other
- Windows versions. }
-
- var FDynamicMenuID: DWORD = $1000;
- {$ENDIF WIN_GDI}
- //[NewMenu DECLARATION]
- function NewMenu( AParent : PControl; MaxCmdReserve: DWORD;
- const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
- {* Menu constructor. First created menu becomes main menu of form (if AParent
- is a form). All other menus becomes popup (can be activated using Popup
- method). To provide dynamic replacing of main menu, create all popup
- menus as children of any other control, not form itself.
- When Menu is created, pass FirstCmd integer value to set it
- as ID of first menu item (all other ID's obtained by incrementing this value),
- and Template, which is an array of PChar (usually array of string constants),
- containing list of menu item identifiers and/or formatting characters.
- |<br>
- FirstCmd value is assigned to first menu item created as its ID,
- all follow menu items are assigned to ID's obtained from FirstCmd incrementing
- it by 1. It is desirable to provide not intersected ranges of ID's for
- defferent menus in the applet.
- |<br>
- Following formatting characters can be used in menu template strings:
- |&L=<br><b>%1</b>
- <L & (in identifier)> - to underline next character and use it as a shortcut character
- when possible;
- <L + (in front of identifier)> - to make item checked. If also
- |<b>!</b> is used before <b>
- &
- |</b> than radioitem is defined;
- <L - (in front of identifier)> - item not checked;
- <L - (separate)> - separator (between two items);
- <L ( (separate)> - start of submenu;
- <L ) (separate)> - end of submenu;
- |<br>
- To get access to menu items, use constants 0, 1, etc. It is a good idea
- to create special enumerated type to index correspondent menu items
- using Ord( ) operator. Note in that case, that it is necessary only to
- define constants correspondent to identifiers (positions, correspondent
- to separators or submenu brackets are not identified by numbers).
- |<br>
- }
-
- function NewMenuEx( AParent : PControl; FirstCmd : Integer;
- const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
- {* Creates menu, assigning its own event handler for every (enough) menu item. }
- {$IFDEF WIN_GDI}
-
- //[MakeAccelerator DECLARATION]
- function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
- {* Creates accelerator item to assign it to TMenu.ItemAccelerator[ ] property
- easy.}
-
- //[GetAcceleratorText DECLARATION]
- // {YS} added 7 Aug 2004
- function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
- {* Returns text representation of accelerator.
- |<hr>
-
- <R System functions and working with windows>
- }
- //[Window FUNCTIONS DECLARATIONS]
- type
- TWindowChildKind = ( wcActive, wcFocus, wcCapture, wcMenuOwner,
- wcMoveSize, wcCaret );
- {* Type of window child kind. Used in function GetWindowChild. }
-
- function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
- {* Returns child of given top-level window, having given characteristics.
- For example, it is possible to get know for foreground window,
- which of its child window has focus. This function does not work in old
- Windows 95 (returns Wnd in that case). But for Windows 98, Windows NT/2000
- this function works fine. To obtain focused child of the window,
- use GetFocusedWindow, which is independant from Windows version. }
- {$ifdef win32}
- function GetFocusedChild( Wnd: HWnd ): HWnd;
- {* Returns focused child of given window (which should be foreground
- and active, certainly). 0 is returned either if Wnd is not active
- or Wnd has no focused child window. }
-
- function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;
- {* Posts characters from string S to those child window of Wnd, which
- has focus now (top-level window Wnd must be foreground, and have
- focused edit-aware control to receive the stroke).
- |<br>
- This function allows only to post typeable characters (including
- such special symbols as #13 (Enter), #9 (Tab), #8 (BackSpace), etc.
- |<br>
- See also function Stroke2WindowEx, which allows to post any key down
- and up events, simulating keyboard for given (automated) application. }
-
- function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;
- {* In addition to function Stroke2Window, this one can send special keys
- to given window, including functional keys and navigation keys. To
- post special key to target window, place a combination of names of
- such key together with keys, which should be passed simultaneously,
- between square or figure brackets. For example, [Ctrl F1], [Alt Shift Home],
- [Ctrl E]. For letters and usual characters, it is not necessary to
- simulate pressing it with determining all Shift combinations and it is
- sufficient to pass characters as is. (E.g., not '[Shift 1]', but '!'). }
- {$endif win32}
- function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
- {* Searches for window, belonging to a given thread. }
-
- function DesktopPixelFormat: TPixelFormat;
- {* Returns the pixel format correspondent to current desktop color resolution.
- Use this function to decide which format to use for converting bitmap,
- planned to draw transparently using TBitmap.DrawTransparent or
- TBitmap.StretchDrawTransparent methods. }
-
- function GetDesktopRect : TRect;
- {* Returns rectangle of screen, free of taskbar and other
- similar app-bars, which reduces size of available desktop
- when created. }
- function GetWorkArea: TRect;
- {* The same as GetDesktopRect, but obtained calling SystemParametersInfo. }
-
- function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
- Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
- {* Allows to execute an application and wait when it is finished. Pass
- INFINITE constant as TimeOut, if You sure that application is finished
- anyway. If another value passed as a TimeOut (in milliseconds), and
- application was not finished for that time, ExecuteWait is returning
- FALSE, and if ProcID is not nil, than ProcID^ contains started process
- handle (it can be used to wait it more, or to terminate it using
- TerminateProcess API function).
- |<br>
- Launching application can be console or GUI - it does not matter.
- Pass SW_SHOW, SW_HIDE or other SW_XXX constant as Show parameter
- as appropriate.
- |<br>
- True is returned only in case when application specified was launched
- successfully and finished for TimeOut specified. Otherwise, check
- ProcID^ variable: if it is 0, process could not be launched (and it
- is possible to get information about error using GetLastError API
- function in a such case). You can freely pass nil in place of ProcID
- parameter, but this is acually correct only when TimeOut is INFINITE. }
- {$ifdef win32}
- function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
- Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
- {* Executes an application with its console input and output redirection.
- Terminating of the application is not waiting, but if ProcID pointer
- is defined, it receives process Id launched, so it is possible to
- call WaitForSingleObject for it. InPipe is a pointer to THandle variable
- which receives a handle to input pipe of the console redirected. The same
- is for OutPipeWr and OutPipeRd, but for output of the console redirected.
- Before reading from OutPipeRd^, first close OutPipeWr^. If you run
- simple console application, for which you want to read results after its
- termination, you can use ExecuteConsoleAppIORedirect instead.
- |<br>
- Notes: if your application is not console and it does not create console
- using AllocConsole, this function will fail to redirect input-output. }
- function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;
- Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD )
- : Boolean;
- {* Executes an application, redirecting its console input and output.
- After redirecting input and output and launching the application,
- content of InStr is written to input stream of the application, then
- the application is waiting for its termination (WaitTimeout milliseconds
- or INFINITE, as passed) and console output of the application is read to
- OutStr. TRUE is returned only in case, when all these tasks are
- completed successfully.
- |<br>
- Notes: if your application is not console and it does not create console
- using AllocConsole, this function will fail to redirect input-output. }
-
- function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
- {* Shut down of Windows NT. Pass Machine = '' to shutdown this PC.
- Pass Reboot = True to reboot immediatelly after shut down. }
- {$endif win32}
- type
- TWindowsVersion = ( wv31, wv95, wv98, wvME, wvNT, wvY2K, wvXP, wvServer2003,
- wvVista, wvCE );
- {* Windows versions constants. }
- TWindowsVersions = Set of TWindowsVersion;
- {* Set of Windows version (e.g. to define a range of versions supported by the
- application). }
-
- function WinVer : TWindowsVersion;
- {* Returns Windows version. }
- function IsWinVer( Ver : TWindowsVersions ) : Boolean;
- {* Returns True if Windows version is in given range of values. }
- //[Parameters FUNCTIONS DECLARATIONS]
- function ParamStr( Idx: Integer ): KOLString;
- {* Returns command-line parameter by index. This function supersides
- standard ParamStr function. }
- function ParamCount: Integer;
- {* Returns number of parameters in command line.
- |<hr>
- }
- {$ifdef wince}
- type
- TCePlatform = (cpWinCE, cpPocketPC, cpSmartphone);
- {*
- Windows CE platfrom constants.
-
- <R WinCE specific functions> }
- function CePlatform: TCePlatform;
- {* Returns Windows CE platfrom. }
- procedure CeFormSIPAware(Form: PControl; ShowSIP: boolean);
- {* Call this procedure to resize form when SIP is activated
- |<hr>
- }
- {$endif wince}
- {$ENDIF WIN_GDI}
-
- {$IFDEF INPACKAGE}
- {$IFDEF ASM_VERSION}
- {$UNDEF ASM_VERSION}
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF WIN_GDI}
- //{$DEFINE CHK_BITBLT}
- procedure Chk_BitBlt;
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_DC}
- {$ENDIF}
- {$IFDEF ASM_DC}
- procedure StartDC;
- procedure FinishDC;
- {$ENDIF ASM_VERSION}
-
- //[WndProcXXX OTHER DECLARATIONS]
- function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
-
- var CreatingWindow: PControl;
- //ActiveWindow: HWnd;
- {$ENDIF WIN_GDI}
- //[Assert OPERATOR DECLARATION]
- {-}
- {$IFDEF _D2}
- // Assert operator was not available in Delphi2. Provide here easy Assert
- // procedure for Delphi2.
- procedure Assert( Cond: Boolean; const Msg: String );
-
- var AssertErrorProc: procedure( const Message, Filename: AnsiString; LineNumber: Integer );
- {$ENDIF}
- {+}
-
- //[CUSTOM EXTENSIONS]
- {$IFDEF USE_CUSTOMEXTENSIONS}
- {$I CUSTOM_KOL_EXTENSION.inc} // See comments in TControl
- {$ENDIF}
-
- {$IFDEF DEBUG_ENDSESSION}
- var EndSession_Initiated: Boolean;
- {$ENDIF}
-
- {$IFDEF WIN_GDI}
- //[FMMNotify VARIABLE]
- var
- FMMNotify: procedure( var Msg: TMsg );
-
- //[procedure ClearText forward declaration]
- procedure ClearText( Sender: PControl );
- //[procedure ClearListbox forward declaration]
- procedure ClearListbox( Sender: PControl );
- //[procedure ClearCombobox forward declaration]
- procedure ClearCombobox( Sender: PControl );
- //[procedure ClearListView forward declaration]
- procedure ClearListView( Sender: PControl );
- //[procedure ClearTreeView forward declaration]
- procedure ClearTreeView( TV: PControl );
-
- //[START OF ACTIONS]
- const
- ButtonActions: TCommandActions = (
- aClear: ClearText;
- aAddText: nil;
- aClick: BN_CLICKED;
- aEnter: BN_SETFOCUS;
- aLeave: BN_KILLFOCUS;
- aChange: 0; //BN_CLICKED;
- aSelChange: 0;
- aGetCount: 0;
- aSetCount: 0;
- aGetItemLength: 0;
- aGetItemText: 0;
- aSetItemText: 0;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: 0;
- aGetSelected: 0;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: 0;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: BS_LEFT;
- aTextAlignRight: BS_RIGHT;
- aTextAlignCenter: BS_CENTER;
- aTextAlignMask: 0;
- aVertAlignCenter: BS_VCENTER shr 8;
- aVertAlignTop: BS_TOP shr 8;
- aVertAlignBottom: BS_BOTTOM shr 8;
- aDir: 0;
- aSetLimit: 0;
- aSetImgList: 0;
- aAutoSzX: 14;
- aAutoSzY: 6;
- aSetBkColor: 0;
- aItem2XY: 0;
- );
-
- const
- LabelActions: TCommandActions = (
- aClear: ClearText;
- aAddText: nil;
- aClick: 0;
- aEnter: 0;
- aLeave: 0;
- aChange: 0;
- aSelChange: 0;
- aGetCount: 0;
- aSetCount: 0;
- aGetItemLength: 0;
- aGetItemText: 0;
- aSetItemText: 0;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: 0;
- aGetSelected: 0;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: 0;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: SS_LEFT;
- aTextAlignRight: SS_RIGHT;
- aTextAlignCenter: SS_CENTER;
- aTextAlignMask: SS_LEFTNOWORDWRAP;
- aVertAlignCenter: SS_CENTERIMAGE shr 8;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: 0;
- aSetLimit: 0;
- aSetImgList: 0;
- aAutoSzX: 1;
- aAutoSzY: 1;
- aSetBkColor: 0;
- aItem2XY: 0;
- );
-
- const
- EN_LINK = $070b;
- EditActions: TCommandActions = (
- aClear: ClearText;
- aAddText: nil;
- aClick: 0;
- aEnter: EN_SETFOCUS;
- aLeave: EN_KILLFOCUS;
- aChange: EN_CHANGE;
- aSelChange: 0;
- aGetCount: EM_GETLINECOUNT;
- aSetCount: 0;
- aGetItemLength: EM_LINELENGTH;
- aGetItemText: EM_GETLINE;
- aSetItemText: EM_REPLACESEL;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: EM_LINEINDEX;
- aPos2Item: EM_LINEFROMCHAR;
- //aGetSelStart: 0;
- aGetSelCount: EM_GETSEL;
- aGetSelected: 0;
- aGetSelRange: EM_GETSEL;
- //aExGetSelRange: 0;
- aGetCurrent: EM_LINEINDEX;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: EM_SETSEL;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: EM_REPLACESEL;
- aTextAlignLeft: ES_LEFT;
- aTextAlignRight: ES_RIGHT;
- aTextAlignCenter: ES_CENTER;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: 0;
- aSetLimit: EM_SETLIMITTEXT;
- aSetImgList: 0;
- aAutoSzX: 0;
- aAutoSzY: 6;
- aSetBkColor: 0;
- aItem2XY: EM_POSFROMCHAR;
- );
-
- const
- ListActions: TCommandActions = (
- aClear: ClearListbox;
- aAddText: nil;
- aClick: LBN_DBLCLK;
- aEnter: LBN_SETFOCUS;
- aLeave: LBN_KILLFOCUS;
- aChange: 0;
- aSelChange: LBN_SELCHANGE;
- aGetCount: LB_GETCOUNT;
- aSetCount: LB_SETCOUNT;
- aGetItemLength: LB_GETTEXTLEN;
- aGetItemText: LB_GETTEXT;
- aSetItemText: 0;
- aGetItemData: LB_GETITEMDATA;
- aSetItemData: LB_SETITEMDATA;
- aAddItem: LB_ADDSTRING;
- aDeleteItem: LB_DELETESTRING;
- aInsertItem: LB_INSERTSTRING;
- aFindItem: LB_FINDSTRINGEXACT;
- aFindPartial: LB_FINDSTRING;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: LB_GETSELCOUNT;
- aGetSelected: LB_GETSEL;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: LB_GETCURSEL;
- aSetSelected: LB_SETSEL;
- aSetCurrent: LB_SETCURSEL;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: 0;
- aTextAlignRight: 0;
- aTextAlignCenter: 0;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: LB_DIR;
- aSetLimit: 0;
- aSetImgList: 0;
- aAutoSzX: 0;
- aAutoSzY: 0;
- aSetBkColor: 0;
- aItem2XY: LB_GETITEMRECT;
- );
-
- const
- ComboActions: TCommandActions = (
- aClear: ClearCombobox;
- aAddText: nil;
- aClick: CBN_DBLCLK;
- aEnter: CBN_SETFOCUS;
- aLeave: CBN_KILLFOCUS;
- aChange: CBN_EDITCHANGE;
- aSelChange: CM_CBN_SELCHANGE; // CBN_SELCHANGE;
- aGetCount: CB_GETCOUNT;
- aSetCount: 0;
- aGetItemLength: CB_GETLBTEXTLEN;
- aGetItemText: CB_GETLBTEXT;
- aSetItemText: 0;
- aGetItemData: CB_GETITEMDATA;
- aSetItemData: CB_SETITEMDATA;
- aAddItem: CB_ADDSTRING;
- aDeleteItem: CB_DELETESTRING;
- aInsertItem: CB_INSERTSTRING;
- aFindItem: CB_FINDSTRINGEXACT;
- aFindPartial: CB_FINDSTRING;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: 0;
- aGetSelected: CB_GETCURSEL;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: CB_GETCURSEL;
- aSetSelected: 0;
- aSetCurrent: CB_SETCURSEL;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: 0; //ES_LEFT;
- aTextAlignRight: 0; //ES_RIGHT;
- aTextAlignCenter: 0; //ES_CENTER;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: CB_DIR;
- aSetLimit: 0;
- aSetImgList: 0;
- aAutoSzX: 0;
- aAutoSzY: 6;
- aSetBkColor: 0;
- aItem2XY: 0;
- );
-
- const
- ListViewActions: TCommandActions = (
- aClear: ClearListView;
- aAddText: nil;
- aClick: 0;
- aEnter: 0;
- aLeave: 0;
- aChange: LVN_ITEMCHANGED;
- aSelChange: 0;
- aGetCount: LVM_GETITEMCOUNT;
- aSetCount: LVM_SETITEMCOUNT;
- aGetItemLength: 0;
- aGetItemText: 0;
- aSetItemText: 0;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: LVM_GETSELECTIONMARK;
- aGetSelCount: { $8000 or} LVM_GETSELECTEDCOUNT;
- aGetSelected: LVM_GETITEMSTATE;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: LVM_GETNEXTITEM;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: 0;
- aTextAlignRight: 0;
- aTextAlignCenter: 0;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: 0;
- aSetLimit: 0;
- aSetImgList: LVM_SETIMAGELIST;
- aAutoSzX: 0;
- aAutoSzY: 0;
- aSetBkColor: LVM_SETBKCOLOR;
- aItem2XY: LVM_GETITEMRECT;
- );
-
- const
- TreeViewActions: TCommandActions = (
- aClear: ClearTreeView;
- aAddText: nil;
- aClick: 0;
- aEnter: 0;
- aLeave: 0;
- aChange: TVN_ENDLABELEDIT;
- aSelChange: TVN_SELCHANGED;
- aGetCount: TVM_GETCOUNT;
- aSetCount: 0;
- aGetItemLength: 0;
- aGetItemText: 0;
- aSetItemText: 0;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: 0;
- aGetSelected: 0;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: 0;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: 0;
- aTextAlignRight: 0;
- aTextAlignCenter: 0;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: CB_DIR;
- aSetLimit: 0;
- aSetImgList: TVM_SETIMAGELIST;
- aAutoSzX: 0;
- aAutoSzY: 0;
- aSetBkColor: {$ifdef wince}0{$else}TVM_SETBKCOLOR{$endif};
- aItem2XY: TVM_GETITEMRECT;
- );
-
- const
- TabControlActions: TCommandActions = (
- aClear: ClearText;
- aAddText: nil;
- aClick: 0;
- aEnter: 0;
- aLeave: 0;
- aChange: TCN_SELCHANGE;
- aSelChange: TCN_SELCHANGE;
- aGetCount: TCM_GETITEMCOUNT;
- aSetCount: 0;
- aGetItemLength: 0;
- aGetItemText: 0;
- aSetItemText: 0;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: 0;
- aPos2Item: 0;
- //aGetSelStart: 0;
- aGetSelCount: 0;
- aGetSelected: 0;
- aGetSelRange: 0;
- //aExGetSelRange: 0;
- aGetCurrent: TCM_GETCURSEL;
- aSetSelected: 0;
- aSetCurrent: TCM_SETCURSEL; //TCM_SETCURFOCUS;
- aSetSelRange: 0;
- aExSetSelRange: 0;
- aGetSelection: 0;
- aReplaceSel: 0;
- aTextAlignLeft: 0;
- aTextAlignRight: 0;
- aTextAlignCenter: 0;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: CB_DIR;
- aSetLimit: 0;
- aSetImgList: TCM_SETIMAGELIST;
- aAutoSzX: 0;
- aAutoSzY: 0;
- aSetBkColor: 0;
- aItem2XY: TCM_GETITEMRECT;
- );
-
- {$IFNDEF NOT_USE_RICHEDIT}
- const
- RichEditActions: TCommandActions = (
- aClear: ClearText;
- aAddText: nil;
- aClick: 0;
- aEnter: EN_SETFOCUS;
- aLeave: EN_KILLFOCUS;
- aChange: EN_CHANGE;
- aSelChange: EN_SELCHANGE;
- aGetCount: EM_GETLINECOUNT;
- aSetCount: 0;
- aGetItemLength: EM_LINELENGTH;
- aGetItemText: EM_GETLINE;
- aSetItemText: EM_REPLACESEL;
- aGetItemData: 0;
- aSetItemData: 0;
- aAddItem: 0;
- aDeleteItem: 0;
- aInsertItem: 0;
- aFindItem: 0;
- aFindPartial: 0;
- aItem2Pos: EM_LINEINDEX;
- aPos2Item: EM_LINEFROMCHAR;
- //aGetSelStart: 0;
- aGetSelCount: EM_GETSEL;
- aGetSelected: 0;
- aGetSelRange: EM_GETSEL;
- //aExGetSelRange: EM_EXGETSEL;
- aGetCurrent: EM_LINEINDEX;
- aSetSelected: 0;
- aSetCurrent: 0;
- aSetSelRange: 0;
- aExSetSelRange: EM_EXSETSEL;
- aGetSelection: EM_GETSELTEXT;
- aReplaceSel: EM_REPLACESEL;
- aTextAlignLeft: ES_LEFT;
- aTextAlignRight: ES_RIGHT;
- aTextAlignCenter: ES_CENTER;
- aTextAlignMask: 0;
- aVertAlignCenter: 0;
- aVertAlignTop: 0;
- aVertAlignBottom: 0;
- aDir: 0;
- aSetLimit: EM_EXLIMITTEXT;
- aSetImgList: 0;
- aAutoSzX: 0;
- aAutoSzY: 0;
- aSetBkColor: EM_SETBKGNDCOLOR;
- aItem2XY: EM_POSFROMCHAR;
- );
- {$ENDIF NOT_USE_RICHEDIT}
-
- const
- BaseFileMethods: TStreamMethods = (
- fSeek: SeekFileStream;
- fGetSiz: GetSizeFileStream;
- fSetSiz: DummySetSize;
- fRead: DummyReadWrite;
- fWrite: DummyReadWrite;
- fClose: CloseFileStream;
- fCustom: nil;
- fWait: nil;
- );
-
- MemoryMethods: TStreamMethods = (
- fSeek: SeekMemStream;
- fGetSiz: GetSizeMemStream;
- fSetSiz: SetSizeMemStream;
- fRead: ReadMemStream;
- fWrite: WriteMemStream;
- fClose: CloseMemStream;
- fCustom: nil;
- fWait: nil;
- );
- {$ENDIF WIN_GDI}
-
- {$IFDEF DEBUG_MCK}
- procedure dummy_Log( const s: String );
- var mck_Log: procedure( const s: String ) = dummy_Log;
- {$ENDIF}
-
- type
- TThemedElement = (
- teButton,
- teClock,
- teComboBox,
- teEdit,
- teExplorerBar,
- teHeader,
- teListView,
- teMenu,
- tePage,
- teProgress,
- teRebar,
- teScrollBar,
- teSpin,
- teStartPanel,
- teStatus,
- teTab,
- teTaskBand,
- teTaskBar,
- teToolBar,
- teToolTip,
- teTrackBar,
- teTrayNotify,
- teTreeview,
- teWindow
- );
-
- var DrawThemeBackground: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
- const pRect: TRect; pClipRect: PRECT): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- ThemeLibrary: THandle;
- IsThemeBackgroundPartiallyTransparent: function(hTheme: DWORD;
- iPartId, iStateId: Integer): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- DrawThemeParentBackground: function(hwnd: HWND; hdc: HDC; prc: PRECT): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- CloseThemeData: function(hTheme: DWORD): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- DrawThemeText: function(hTheme: DWORD; hdc: HDC; iPartId, iStateId: Integer;
- pszText: LPCWSTR; iCharCount: Integer; dwTextFlags, dwTextFlags2: DWORD;
- const pRect: TRect): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- IsThemeActive: function: BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- IsAppThemed: function: BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- GetThemeColor: function(hTheme: DWORD; iPartId, iStateId, iPropId: Integer;
- var pColor: COLORREF): HRESULT; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- const
- themelib = 'uxtheme';
-
- type
- PThemedElementDetails = ^TThemedElementDetails;
- TThemedElementDetails = record
- Element: TThemedElement;
- Part,
- State: Integer;
- end;
- TThemedEdit = (
- teEditDontCare,
- teEditRoot,
- teEditTextNormal, teEditTextHot, teEditTextSelected, teEditTextDisabled, teEditTextFocused, teEditTextReadOnly, teEditTextAssist,
- teEditCaret
- );
-
- //[IMPLEMENTATION]
- implementation
-
- //[USES-2]
- {uses
- //ShellAPI,
- //commdlg // removing reference to commdlg decreases executable about 0.5 K
- ; //, commctrl;
- // in Delphi3, including of commctrl.pas increases executable
- // onto about 30K. So, all needed definitions are copied here
- // (see commctrl.inc).}
- //[END OF USES-2]
-
- {$IFDEF _X_}
- {$undef uses_2}
- {$IFNDEF NOT_USE_KOLMATH}
- {$define uses_2}
- {$ENDIF NOT_USE_KOLMATH}
- {$IFDEF uses_2}
- uses {$IFNDEF NOT_USE_KOLMATH} KOLmath
- {$IFNDEF NOT_USE_EXCEPTION} , err
- {$IFDEF REDECLARATION_INSERTED_AUTOMATICALLY}
- , gdk2, pango, gtk2
- {$ENDIF REDECLARATION_INSERTED_AUTOMATICALLY}
- {$ENDIF NOT_USE_EXCEPTION}
- {$ENDIF NOT_USE_KOLMATH};
- {$ENDIF uses_2}
- {$ELSE}
- {$IFDEF USE_GRUSH}
- uses ToGRush;
- {$ELSE}
- {$IFDEF INPACKAGE}
- uses mirror, SysUtils;
- {$ENDIF INPACKAGE}
- {$ENDIF USE_GRUSH}
- {$ENDIF _X_}
-
- {$IFDEF WIN32}
- {$IFDEF UNICODE_CTRLS}
- {$DEFINE implementation_part} {$I KOL_unicode.inc} {$UNDEF implementation_part}
- {$ENDIF UNICODE_CTRLS}
- {$ENDIF WIN32}
-
- {$IFDEF DEBUG_MCK}
- procedure dummy_Log( const s: String );
- begin
- //
- end;
- {$ENDIF}
- {$IFDEF WIN}
- {$ifdef win32}
- type
- PSHFileInfoA = ^TSHFileInfoA;
- PSHFileInfoW = ^TSHFileInfoW;
- PSHFileInfo = PSHFileInfoA;
- _SHFILEINFOA = record
- hIcon: HICON; { out: icon }
- iIcon: Integer; { out: icon index }
- dwAttributes: DWORD; { out: SFGAO_ flags }
- szDisplayName: array [0..MAX_PATH-1] of AnsiChar; { out: display name (or path) }
- szTypeName: array [0..79] of AnsiChar; { out: type name }
- end;
- _SHFILEINFOW = record
- hIcon: HICON; { out: icon }
- iIcon: Integer; { out: icon index }
- dwAttributes: DWORD; { out: SFGAO_ flags }
- szDisplayName: array [0..MAX_PATH-1] of WideChar; { out: display name (or path) }
- szTypeName: array [0..79] of WideChar; { out: type name }
- end;
- _SHFILEINFO = {$IFDEF UNICODE_CTRLS} _SHFILEINFOW {$ELSE} _SHFILEINFOA {$ENDIF};
- TSHFileInfoA = _SHFILEINFOA;
- TSHFileInfoW = _SHFILEINFOW;
- TSHFileInfo = {$IFDEF UNICODE_CTRLS} TSHFileInfoW {$ELSE} TSHFileInfoA {$ENDIF};
- SHFILEINFOA = _SHFILEINFOA;
- SHFILEINFOW = _SHFILEINFOW;
- SHFILEINFO = {$IFDEF UNICODE_CTRLS} SHFILEINFOW {$ELSE} SHFILEINFOA {$ENDIF};
-
- const
- SHGFI_ICON = $000000100; { get icon }
- SHGFI_DISPLAYNAME = $000000200; { get display name }
- SHGFI_TYPENAME = $000000400; { get type name }
- SHGFI_ATTRIBUTES = $000000800; { get attributes }
- SHGFI_ICONLOCATION = $000001000; { get icon location }
- SHGFI_EXETYPE = $000002000; { return exe type }
- SHGFI_SYSICONINDEX = $000004000; { get system icon index }
- SHGFI_LINKOVERLAY = $000008000; { put a link overlay on icon }
- SHGFI_SELECTED = $000010000; { show icon in selected state }
- SHGFI_LARGEICON = $000000000; { get large icon }
- SHGFI_SMALLICON = $000000001; { get small icon }
- SHGFI_OPENICON = $000000002; { get open icon }
- SHGFI_SHELLICONSIZE = $000000004; { get shell size icon }
- SHGFI_PIDL = $000000008; { pszPath is a pidl }
- SHGFI_USEFILEATTRIBUTES = $000000010; { use passed dwFileAttribute }
-
- function SHGetFileInfoA(pszPath: PAnsiChar; dwFileAttributes: DWORD;
- var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHGetFileInfoA';
- {$IFDEF UNICODE_CTRLS}
- function SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD;
- var psfi: TSHFileInfo; cbFileInfo, uFlags: UINT): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHGetFileInfoW';
- {$ENDIF UNICODE_CTRLS}
-
- type
- FILEOP_FLAGS = Word;
- PRINTEROP_FLAGS = Word;
-
- PSHFileOpStructA = ^TSHFileOpStructA;
- PSHFileOpStructW = ^TSHFileOpStructW;
- PSHFileOpStruct = PSHFileOpStructA;
- _SHFILEOPSTRUCTA = {$ifndef wince}packed{$endif} record
- Wnd: HWND;
- wFunc: UINT;
- pFrom: PAnsiChar;
- pTo: PAnsiChar;
- fFlags: FILEOP_FLAGS;
- fAnyOperationsAborted: BOOL;
- hNameMappings: Pointer;
- lpszProgressTitle: PAnsiChar; { only used if FOF_SIMPLEPROGRESS }
- end;
- _SHFILEOPSTRUCTW = {$ifndef wince}packed{$endif} record
- Wnd: HWND;
- wFunc: UINT;
- pFrom: PWideChar;
- pTo: PWideChar;
- fFlags: FILEOP_FLAGS;
- fAnyOperationsAborted: BOOL;
- hNameMappings: Pointer;
- lpszProgressTitle: PWideChar; { only used if FOF_SIMPLEPROGRESS }
- end;
- _SHFILEOPSTRUCT = _SHFILEOPSTRUCTA;
- TSHFileOpStructA = _SHFILEOPSTRUCTA;
- TSHFileOpStructW = _SHFILEOPSTRUCTW;
- TSHFileOpStruct = TSHFileOpStructA;
- SHFILEOPSTRUCTA = _SHFILEOPSTRUCTA;
- SHFILEOPSTRUCTW = _SHFILEOPSTRUCTW;
- SHFILEOPSTRUCT = SHFILEOPSTRUCTA;
-
- const
- FO_MOVE = $0001;
- FO_COPY = $0002;
- FO_DELETE = $0003;
- FO_RENAME = $0004;
-
- FOF_MULTIDESTFILES = $0001;
- FOF_CONFIRMMOUSE = $0002;
- FOF_SILENT = $0004; { don't create progress/report }
- FOF_RENAMEONCOLLISION = $0008;
- FOF_NOCONFIRMATION = $0010; { Don't prompt the user. }
- FOF_WANTMAPPINGHANDLE = $0020; { Fill in SHFILEOPSTRUCT.hNameMappings
- Must be freed using SHFreeNameMappings }
- FOF_ALLOWUNDO = $0040;
- FOF_FILESONLY = $0080; { on *.*, do only files }
- FOF_SIMPLEPROGRESS = $0100; { means don't show names of files }
- FOF_NOCONFIRMMKDIR = $0200; { don't confirm making any needed dirs }
- FOF_NOERRORUI = $0400; { don't put up error UI }
-
-
- function SHFileOperationW(const lpFileOp: TSHFileOpStructW): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHFileOperationW';
-
- function SHFileOperationA(const lpFileOp: TSHFileOpStructA): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHFileOperationA';
-
- type
- PNotifyIconDataA = ^TNotifyIconDataA;
- PNotifyIconDataW = ^TNotifyIconDataW;
- PNotifyIconData = PNotifyIconDataA;
- _NOTIFYICONDATAA = record
- cbSize: DWORD;
- Wnd: HWND;
- uID: UINT;
- uFlags: UINT;
- uCallbackMessage: UINT;
- hIcon: HICON;
- szTip: array [0..63] of AnsiChar;
- end;
- _NOTIFYICONDATAW = record
- cbSize: DWORD;
- Wnd: HWND;
- uID: UINT;
- uFlags: UINT;
- uCallbackMessage: UINT;
- hIcon: HICON;
- szTip: array [0..63] of WideChar;
- end;
- _NOTIFYICONDATA = _NOTIFYICONDATAA;
- TNotifyIconDataA = _NOTIFYICONDATAA;
- TNotifyIconDataW = _NOTIFYICONDATAW;
- TNotifyIconData = TNotifyIconDataA;
- NOTIFYICONDATAA = _NOTIFYICONDATAA;
- NOTIFYICONDATAW = _NOTIFYICONDATAW;
- NOTIFYICONDATA = NOTIFYICONDATAA;
-
- const
- NIM_ADD = $00000000;
- NIM_MODIFY = $00000001;
- NIM_DELETE = $00000002;
-
- NIF_MESSAGE = $00000001;
- NIF_ICON = $00000002;
- NIF_TIP = $00000004;
-
- {$IFDEF UNICODE_CTRLS}
- function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconDataW): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'Shell_NotifyIconW';
- {$ELSE}
- function Shell_NotifyIcon(dwMessage: DWORD; lpData: PNotifyIconData): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'Shell_NotifyIconA';
- {$ENDIF UNICODE_CTRLS}
-
- {$IFDEF UNICODE_CTRLS}
- function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
- nIconIndex: UINT): HICON; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'ExtractIconW';
- {$ELSE}
- function ExtractIcon(hInst: HINST; lpszExeFileName: PKOLChar;
- nIconIndex: UINT): HICON; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'ExtractIconA';
- {$ENDIF UNICODE_CTRLS}
- {$endif win32}
- {$ENDIF WIN}
- {$IFDEF WIN_GDI}
- {$ifdef win32}
- type
- HDROP = Longint;
-
- function DragQueryPoint(Drop: HDROP; var Point: TPoint): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'DragQueryPoint';
- {$IFDEF UNICODE_CTRLS}
- function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PWideChar; cb: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'DragQueryFileW';
- {$ELSE}
- function DragQueryFile(Drop: HDROP; FileIndex: UINT; FileName: PChar; cb: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'DragQueryFileA';
- {$ENDIF UNICODE_CTRLS}
- procedure DragFinish(Drop: HDROP); {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'DragFinish';
- procedure DragAcceptFiles(Wnd: HWND; Accept: BOOL); {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'DragAcceptFiles';
-
- const
- OFN_READONLY = $00000001;
- OFN_OVERWRITEPROMPT = $00000002;
- OFN_HIDEREADONLY = $00000004;
- OFN_NOCHANGEDIR = $00000008;
- OFN_SHOWHELP = $00000010;
- OFN_ENABLEHOOK = $00000020;
- OFN_ENABLETEMPLATE = $00000040;
- OFN_ENABLETEMPLATEHANDLE = $00000080;
- OFN_NOVALIDATE = $00000100;
- OFN_ALLOWMULTISELECT = $00000200;
- OFN_EXTENSIONDIFFERENT = $00000400;
- OFN_PATHMUSTEXIST = $00000800;
- OFN_FILEMUSTEXIST = $00001000;
- OFN_CREATEPROMPT = $00002000;
- OFN_SHAREAWARE = $00004000;
- OFN_NOREADONLYRETURN = $00008000;
- OFN_NOTESTFILECREATE = $00010000;
- OFN_NONETWORKBUTTON = $00020000;
- OFN_NOLONGNAMES = $00040000;
- OFN_EXPLORER = $00080000;
- OFN_NODEREFERENCELINKS = $00100000;
- OFN_LONGNAMES = $00200000;
- OFN_ENABLEINCLUDENOTIFY = $00400000;
- OFN_ENABLESIZING = $00800000;
- OFN_DONTADDTORECENT = $02000000;
- OFN_FORCESHOWHIDDEN = $10000000; // Show All files including System and hidden files
- OFN_EX_NOPLACESBAR = $00000001;
- OFN_SHAREFALLTHROUGH = 2;
- OFN_SHARENOWARN = 1;
- OFN_SHAREWARN = 0;
- type
- POpenFilename = ^TOpenFilename;
- tagOFN = {$ifndef wince}packed{$endif} record
- lStructSize: DWORD;
- hWndOwner: HWND;
- hInstance: HINST;
- lpstrFilter: PKOLChar;
- lpstrCustomFilter: PKOLChar;
- nMaxCustFilter: DWORD;
- nFilterIndex: DWORD;
- lpstrFile: PKOLChar;
- nMaxFile: DWORD;
- lpstrFileTitle: PKOLChar;
- nMaxFileTitle: DWORD;
- lpstrInitialDir: PKOLChar;
- lpstrTitle: PKOLChar;
- Flags: DWORD;
- nFileOffset: Word;
- nFileExtension: Word;
- lpstrDefExt: PKOLChar;
- lCustData: LPARAM;
- lpfnHook: function(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
- lpTemplateName: PKOLChar;
- {$IFDEF OpenSaveDialog_Extended}
- //---------- added from Windows2000:
- pvReserved: Pointer;
- dwReserved: DWORD;
- FlagsEx: DWORD;
- {$ENDIF}
- end;
- TOpenFilename = tagOFN;
- OPENFILENAME = tagOFN;
- {$IFDEF UNICODE_CTRLS}
- function GetOpenFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'comdlg32.dll' name 'GetOpenFileNameW';
- function GetSaveFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'comdlg32.dll' name 'GetSaveFileNameW';
- {$ELSE}
- function GetOpenFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'comdlg32.dll' name 'GetOpenFileNameA';
- function GetSaveFileName(var OpenFile: TOpenFilename): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'comdlg32.dll' name 'GetSaveFileNameA';
- {$ENDIF UNICODE_CTRLS}
-
- type
- PChooseColorA = ^TChooseColorA;
- PChooseColorW = ^TChooseColorW;
- PChooseColor = PChooseColorA;
- tagCHOOSECOLORA = {$ifndef wince}packed{$endif} record
- lStructSize: DWORD;
- hWndOwner: HWND;
- hInstance: HWND;
- rgbResult: COLORREF;
- lpCustColors: ^COLORREF;
- Flags: DWORD;
- lCustData: LPARAM;
- lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
- lpTemplateName: PAnsiChar;
- end;
- tagCHOOSECOLORW = {$ifndef wince}packed{$endif} record
- lStructSize: DWORD;
- hWndOwner: HWND;
- hInstance: HWND;
- rgbResult: COLORREF;
- lpCustColors: ^COLORREF;
- Flags: DWORD;
- lCustData: LPARAM;
- lpfnHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT {$ifdef wince}cdecl{$else}stdcall{$endif};
- lpTemplateName: PWideChar;
- end;
- tagCHOOSECOLOR = tagCHOOSECOLORA;
- TChooseColorA = tagCHOOSECOLORA;
- TChooseColorW = tagCHOOSECOLORW;
- TChooseColor = TChooseColorA;
-
- const
- CC_RGBINIT = $00000001;
- CC_FULLOPEN = $00000002;
- CC_PREVENTFULLOPEN = $00000004;
- CC_SHOWHELP = $00000008;
- CC_ENABLEHOOK = $00000010;
- CC_ENABLETEMPLATE = $00000020;
- CC_ENABLETEMPLATEHANDLE = $00000040;
- CC_SOLIDCOLOR = $00000080;
- CC_ANYCOLOR = $00000100;
-
- function ChooseColor(var CC: TChooseColor): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'comdlg32.dll' name 'ChooseColorA';
- {$endif win32}
-
- {$IFDEF GDI}
- //[procedure Chk_BitBlt_ShowError]
- procedure Chk_BitBlt_ShowError;
- var Rslt: Integer;
- begin
- Rslt := GetLastError;
- ShowMessage( 'BitBlt ERROR: ' + Int2Str( Rslt )
- + ' ' + SysErrorMessage( Rslt ) );
- end;
- //[END Chk_BitBlt_ShowError]
-
- //[procedure Chk_BitBlt]
- {$ifdef wince}
- procedure Chk_BitBlt;
- begin
- end;
- {$else}
- procedure Chk_BitBlt;
- var Rslt: Integer;
- begin
- asm
- MOV Rslt, EAX
- end;
- if Rslt = 0 then
- begin
- Chk_BitBlt_ShowError;
- asm
- int 3;
- end;
- end;
- end;
- {$endif wince}
- //[END Chk_BitBlt]
- {$ENDIF GDI}
-
- {-}
- {$ifdef _D2}
-
- //[PROCEDURE Assert]
- procedure Assert( Cond: Boolean; const Msg: String );
- begin
- if not Cond then
- begin
- AssertErrorProc( Msg, '', 0 );
- //MsgOK( Msg );
- asm
- int 3;
- end;
- end;
- end;
-
- //[API CreateDIBSection]
- function CreateDIBSection(DC: HDC; const p2: TBitmapInfo; p3: UINT;
- var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external gdi32 name 'CreateDIBSection';
-
- //[PROCEDURE _LStrFromPCharLen]
- procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
- asm
- { -> EAX pointer to dest }
- { EDX source }
- { ECX length }
-
- PUSH EBX
- PUSH ESI
- PUSH EDI
-
- MOV EBX,EAX
- MOV ESI,EDX
- MOV EDI,ECX
-
- { allocate new string }
-
- MOV EAX,EDI
-
- CALL System.@NewAnsiString
- MOV ECX,EDI
- MOV EDI,EAX
-
- TEST ESI,ESI
- JE @@noMove
-
- MOV EDX,EAX
- MOV EAX,ESI
- CALL Move
-
- { assign the result to dest }
-
- @@noMove:
- MOV EAX,EBX
- CALL System.@LStrClr
- MOV [EBX],EDI
-
- POP EDI
- POP ESI
- POP EBX
- end;
- {$endif}
- {+}
-
- {$ifdef win32}
- //[API InitCommonControls]
- procedure InitCommonControls; external cctrl name 'InitCommonControls';
-
- type
- TInitCommonControlsEx = {$ifndef wince}packed{$endif} record
- dwSize: DWORD;
- dwICC: DWORD;
- end;
- PInitCommonControlsEx = ^TInitCommonControlsEx;
-
- var ComCtl32_Module: HModule;
- //[procedure DoInitCommonControls]
- procedure DoInitCommonControls( dwICC: DWORD );
- var Proc: procedure( ICC: PInitCommonControlsEx ); {$ifdef wince}cdecl{$else}stdcall{$endif};
- ICC: TInitCommonControlsEx;
- begin
- InitCommonControls;
- if ComCtl32_Module = 0 then
- ComCtl32_Module := LoadLibrary( 'comctl32' );
- @ Proc := GetProcAddress( ComCtl32_Module, 'InitCommonControlsEx' );
- if Assigned( Proc ) then
- begin
- ICC.dwSize := Sizeof( ICC );
- ICC.dwICC := dwICC;
- Proc( @ ICC );
- end;
- end;
- {$else}
- procedure DoInitCommonControls( dwICC: DWORD );
- var
- ICC: TInitCommonControlsEx;
- begin
- ICC.dwSize := Sizeof( ICC );
- ICC.dwICC := dwICC;
- InitCommonControlsEx(@ICC);
- end;
- {$endif win32}
- //[END DoInitCommonControls]
-
- const size_TRect = 16; // used often in assembler versions of code
- {-}
-
- {$IFDEF ASM_VERSION}
- const
- EmptyString: String = '';
-
- //[PROCEDURE EAX2PChar]
- procedure EAX2PChar;
- asm
- TEST EAX, EAX
- JNZ @@exit
- MOV EAX, offset[EmptyString]
- @@exit:
- end;
-
- //[PROCEDURE EDX2PChar]
- procedure EDX2PChar;
- asm
- TEST EDX, EDX
- JNZ @@exit
- MOV EDX, offset[EmptyString]
- @@exit:
- end;
-
- //[PROCEDURE ECX2PChar]
- procedure ECX2PChar;
- asm
- JECXZ @@convert
- RET
- @@convert:
- MOV ECX, offset[EmptyString]
- @@exit:
- end;
-
- //[PROCEDURE RemoveStr]
- procedure RemoveStr;
- asm
- { <- [ESP+4] = string to remove
- -> ESP := ESP + 4
- EAX = 0
- }
- POP EAX
- XCHG EAX, [ESP]
- PUSH EAX
- MOV EAX, ESP
- CALL System.@LStrClr
- POP EAX
- end;
- {$ELSE ASM_VERSION}
- {$ENDIF ASM_VERSION}
- {+}
-
- const PossibleColorBits : array[1..7] of Byte = ( 1, 4, 8, 16, 24, 32, 0 );
-
- function FindFilter( const Filter: KOLString): KOLString; forward;
- function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD; forward;
- procedure CreateComboboxWnd( Combo: PControl ); forward;
- procedure ComboboxDropDown( Sender: PObj ); forward;
- function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- {$ifndef wince}
- function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
- {$endif wince}
- function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean; forward;
- function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
- function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
- function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
- procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD ); forward;
- function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer; forward;
- procedure ApplyImageLists2Control( Sender: PControl ); forward;
- procedure ApplyImageLists2ListView( Sender: PControl ); forward;
- {$ifdef win32}
- function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
- function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
- Integer; {$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
- {$endif win32}
- function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif}; forward;
- function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo; forward;
- procedure PreparePF16bit( DIBHeader: PBitmapInfo ); forward;
- procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
- procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
- procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
- procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
- procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap ); forward;
- procedure _RotateBitmapRight( SrcBmp: PBitmap ); forward;
- procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
- procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
- procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
- procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor ); forward;
- procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer ); forward;
- procedure DetachBitmapFromCanvas( Sender: PBitmap ); forward;
- function ColorBits( ColorsCount : Integer ) : Integer; forward;
- procedure AlignChildrenProc(Sender: PObj); forward;
- function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function CollectTabControls( Form: PControl ): PList; forward;
- {$IFNDEF NOT_USE_RICHEDIT}
- function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- {$ENDIF NOT_USE_RICHEDIT}
- function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean; forward;
- function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- forward;
- function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- forward;
- function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
- forward;
- procedure Tabulate2Next( Form: PControl; Dir: Integer ); forward;
- function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
- forward;
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- {$I visual_xp_styles.inc}
- {$ENDIF}
-
- {$ifdef wince}
- var
- _CePlatform: byte = 255;
-
- function CePlatform: TCePlatform;
- var
- buf: array[0..50] of WideChar;
- begin
- if _CePlatform = $FF then begin
- Result := cpWinCE;
- if SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then begin
- if WStrCmp(@buf, 'PocketPC') = 0 then
- Result := cpPocketPC
- else
- if WStrCmp(@buf, 'SmartPhone') = 0 then
- Result := cpSmartphone;
- end
- else
- if GetLastError = ERROR_ACCESS_DENIED then
- Result := cpSmartphone;
- _CePlatform:=byte(Result);
- end
- else
- Result:=TCePlatform(_CePlatform);
- end;
-
- function WndProcSIPAware(Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- begin
- Result:=False;
- case Msg.message of
- WM_ACTIVATE:
- begin
- if PSHACTIVATEINFO(Sender.fCustomData).bits < 0 then begin
- SHSipPreference(Msg.hwnd, SIPSTATE(PSHACTIVATEINFO(Sender.fCustomData).bits + 10));
- PSHACTIVATEINFO(Sender.fCustomData).bits:=0;
- end;
- SHHandleWMActivate(Msg.hwnd, Msg.wParam, Msg.lParam, Sender.fCustomData, SHA_INPUTDIALOG);
- end;
- WM_SETTINGCHANGE:
- SHHandleWMSettingChange(Msg.hwnd, Msg.wParam, Msg.lParam, Sender.fCustomData);
- end;
- end;
-
- procedure CeFormSIPAware(Form: PControl; ShowSIP: boolean);
-
- procedure CreateSIPPref(C: PControl);
- var
- i: integer;
- begin
- for i:=0 to C.ChildCount - 1 do
- CreateSIPPref(C.Children[i]);
- if C.ChildCount > 0 then
- CreateWindowEx(0, 'SIPPREF', '', WS_CHILD , -10, -10, 5, 5, C.Handle, 0, 0, 0);
- end;
-
- begin
- GetMem(Form.fCustomData, SizeOf(SHACTIVATEINFO));
- FillChar(Form.fCustomData^, SizeOf(SHACTIVATEINFO), 0);
- with PSHACTIVATEINFO(Form.fCustomData)^ do begin
- cbSize:=SizeOf(SHACTIVATEINFO);
- if ShowSIP then
- bits:=integer(SIP_UP) - 10
- else
- bits:=integer(SIP_FORCEDOWN) - 10;
- end;
- Form.AttachProc(WndProcSIPAware);
- SHInitExtraControls;
- Form.CreateChildWindows;
- CreateSIPPref(Form);
- end;
-
- function InsertMenuItem(Menu: HMENU; uItem: UINT; fByPosition: BOOL; const MII: TMenuItemInfo): BOOL;
- var
- id, Flags: UINT;
- begin
- if MII.hSubMenu <> 0 then begin
- Flags:=MF_POPUP;
- id:=MII.hSubMenu;
- end
- else begin
- id:=MII.wID;
- Flags:=MII.fType and not MFT_RADIOCHECK;
- if MII.fType and MFT_SEPARATOR = 0 then
- Flags:=Flags or MII.fState;
- end;
- if fByPosition then
- Flags:=Flags or MF_BYPOSITION;
- Result:=InsertMenu(Menu, uItem, Flags and not MF_DISABLED, id, MII.dwTypeData);
- if (MII.fType and MFT_RADIOCHECK <> 0) and (MII.fState and MFS_CHECKED <> 0) then
- CheckMenuRadioItem(Menu, MII.wID, MII.wID, MII.wID, MF_BYCOMMAND);
- end;
-
- var
- CeSetMenuProc: procedure (Wnd: HWND; Menu: PMenu) = nil;
-
- procedure CeSetMenu(Wnd: HWND; Menu: PMenu);
- begin
- if Assigned(CeSetMenuProc) then
- CeSetMenuProc(Wnd, Menu);
- end;
-
- procedure CeSetMenuHandler(Wnd: HWND; Menu: PMenu);
- var
- mbi: SHMENUBARINFO;
- tb: TBButton;
- tbbi : TBBUTTONINFO;
- i, j: integer;
- st: byte;
- R, BR: TRect;
- begin
- if (Menu <> nil) and (CePlatform = cpSmartphone) then
- Menu.SaveState;
- GetWindowRect(Wnd, BR);
- mbi.hwndMB:=SHFindMenuBar(Wnd);
- if (mbi.hwndMB <> 0) and (CePlatform = cpSmartphone) then begin
- DestroyWindow(mbi.hwndMB);
- mbi.hwndMB:=0;
- end;
- if mbi.hwndMB = 0 then begin
- FillChar(mbi, SizeOf(mbi), 0);
- with mbi do begin
- cbSize:=SizeOf(mbi);
- hwndParent:=Wnd;
- nToolBarId:=20000;
- hInstRes:=HINSTANCE;
- if CePlatform = cpSmartphone then
- if Menu <> nil then begin
- i:=0;
- for j:=0 to Menu.FItems.Count - 1 do
- with PMenu(Menu.FItems.Items[j])^ do
- if Visible then begin
- Inc(i);
- if (i = 1) and (SubMenu <> 0) then
- Inc(nToolBarId)
- else
- if i = 2 then begin
- if SubMenu <> 0 then
- Inc(nToolBarId, 2);
- break;
- end;
- end;
- end;
- end;
- if not SHCreateMenuBar(@mbi) then
- exit;
- end;
-
- while SendMessage(mbi.hwndMB, TB_DELETEBUTTON, 0, 0) <> 0 do ;
- if Menu <> nil then begin
- i:=0;
- for j:=0 to Menu.FItems.Count - 1 do
- with PMenu(Menu.FItems.Items[j])^ do
- if Visible then begin
- if FSavedState and MFS_DISABLED = 0 then
- st:=TBSTATE_ENABLED
- else
- st:=0;
- if FSavedState and MFS_CHECKED <> 0 then
- st:=st or TBSTATE_CHECKED;
- if CePlatform = cpSmartphone then begin
- if i = 2 then
- break; // smartphones have maximum 2 top level menu items.
- tbbi.cbSize := sizeof(tbbi);
- tbbi.pszText := PKOLChar(Caption);
- tbbi.idCommand := FID;
- tbbi.dwMask := TBIF_TEXT or TBIF_COMMAND or TBIF_STATE;
- tbbi.fsState:=st;
- SendMessage(mbi.hwndMB, TB_SETBUTTONINFO, i + 1, LPARAM(@tbbi));
- if FHandle <> 0 then begin
- tbbi.dwMask := TBIF_LPARAM;
- SendMessage (mbi.hwndMB, TB_GETBUTTONINFO, FID, LPARAM(@tbbi));
- DestroyMenu(FHandle);
- FHandle:=HMENU(tbbi.lParam);
- ReCreate;
- end;
- end
- else begin
- FillChar(tb, SizeOf(tb), 0);
- tb.iBitmap:=I_IMAGENONE;
- tb.idCommand:=fID;
- tb.iString:=longint(PKOLChar(Caption));
- tb.fsState:=st;
- if SubMenu <> 0 then
- tb.fsStyle:=TBSTYLE_DROPDOWN or $0080 or TBSTYLE_AUTOSIZE
- else
- tb.fsStyle:=TBSTYLE_BUTTON or TBSTYLE_AUTOSIZE;
- tb.dwData:=SubMenu;
- SendMessage(mbi.hwndMB, TB_INSERTBUTTON, i, LPARAM(@tb));
- end;
- Inc(i);
- end;
-
- if (CePlatform = cpSmartphone) and (i = 1) then begin
- tbbi.dwMask := TBIF_STATE;
- tbbi.fsState:=0;
- SendMessage(mbi.hwndMB, TB_SETBUTTONINFO, 2, LPARAM(@tbbi));
- end;
- end;
-
- GetWindowRect(mbi.hwndMB, R);
- if BR.Bottom > R.Top then
- SetWindowPos(wnd, 0, 0, 0, BR.Right - BR.Left, R.Top - BR.Top, SWP_NOZORDER or SWP_NOREPOSITION or SWP_NOMOVE);
- end;
- {$endif wince}
-
- {$IFDEF SNAPMOUSE2DFLTBTN}
- var FoundMsgBoxWnd: HWnd;
-
- function EnumProcSnapMouse2DfltBtn( W: HWnd; lParam: Integer ): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var ClassBuf: array[ 0..31 ] of KOLChar;
- begin
- GetClassName( W, ClassBuf, Sizeof( ClassBuf ) div Sizeof( KOLChar ) );
- Result := TRUE;
- if ClassBuf = '#32770' then
- begin
- FoundMsgBoxWnd := W;
- Result := FALSE;
- end;
- end;
-
- function WndProcSnapMouse2DfltBtn( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
- var W: HWnd;
- R: TRect;
- P: TPoint;
- SnapMouse: Integer;
- begin
- SnapMouse := 0;
- if SystemParametersInfo( SPI_GETSNAPTODEFBUTTON, 0, @ SnapMouse, 0 ) then
- if SnapMouse <> 0 then
- begin
- FoundMsgBoxWnd := 0;
- EnumThreadWindows( GetCurrentThreadID, @ EnumProcSnapMouse2DfltBtn, 0 );
- if FoundMsgBoxWnd <> 0 then
- begin
- W := GetWindow( FoundMsgBoxWnd, GW_CHILD );
- while W <> 0 do
- begin
- if GetWindowLong( W, GWL_STYLE ) and BS_DEFPUSHBUTTON <> 0 then
- begin
- GetWindowRect( W, R );
- P.X := (R.Left + R.Right) div 2;
- P.Y := (R.Top + R.Bottom) div 2;
- SetCursorPos( P.X, P.Y );
- end;
- W := GetWindow( W, GW_HWNDNEXT );
- end;
- Applet.DetachProc( WndProcSnapMouse2DfltBtn );
- end;
- end;
- Result := FALSE;
- end;
- {$ENDIF SNAPMOUSE2DFLTBTN}
-
- {$IFDEF GDI}
- //[function MsgBox]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
- var Title: PKOLChar;
- begin
- Title := nil;
- if assigned( Applet ) then
- begin
- Title := PKOLChar( Applet.fCaption );
- end;
- {$IFDEF SNAPMOUSE2DFLTBTN}
- if Assigned( Applet ) then
- begin
- Applet.AttachProc( WndProcSnapMouse2DfltBtn );
- Applet.Postmsg( 0, 0, 0 );
- end;
- {$ENDIF}
- Result := MessageBox( 0, PKOLChar( S ), Title, Flags );
- {$IFDEF SNAPMOUSE2DFLTBTN}
- if Assigned( Applet ) then
- Applet.DetachProc( WndProcSnapMouse2DfltBtn );
- {$ENDIF}
- end;
- //[END MsgBox]
- {$ENDIF ASM_VERSION}
-
- //[PROCEDURE MsgOK]
- procedure MsgOK( const S: KOLString );
- begin
- MsgBox( S, MB_OK );
- end;
-
- //[function ShowMsg]
- {$IFDEF ASM_UNICODE}
- function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
- asm
- push edx // Flags
- mov ecx, [Applet]
- {$IFDEF SNAPMOUSE2DFLTBTN}
- jecxz @@0
- pushad
- xchg eax, ecx
- mov edx, offset[WndProcSnapMouse2DfltBtn]
- call TControl.AttachProc
- popad
- @@0:
- {$ENDIF}
- mov edx, 0
- jecxz @@1
- mov edx, [ecx].TControl.fHandle
- mov ecx, [ecx].TControl.fCaption
- @@1: push ecx // Title
- push eax // S
- push edx // Wnd
- call MessageBox
- {$IFDEF SNAPMOUSE2DFLTBTN}
- mov ecx, [Applet]
- jecxz @@2
- pushad
- xchg eax, ecx
- mov edx, offset[WndProcSnapMouse2DfltBtn]
- call TControl.DetachProc
- popad
- @@2:
- {$ENDIF}
- end;
- {$ELSE PASCAL}
- function ShowMsg( const S: KOLString; Flags: DWORD ): DWORD;
- var Title: PKOLChar;
- Wnd: HWnd;
- begin
- {$IFDEF SNAPMOUSE2DFLTBTN}
- if Assigned( Applet ) then
- Applet.AttachProc( WndProcSnapMouse2DfltBtn );
- {$ENDIF}
- Title := nil;
- Wnd := 0;
- if assigned( Applet ) then
- begin
- Title := PKOLChar( Applet.fCaption );
- //{$IFNDEF SNAPMOUSE2DFLTBTN}
- Wnd := Applet.Handle;
- //{$ENDIF}
- end;
- Result := MessageBox( Wnd, PKOLChar( S ), Title, Flags );
- {$IFDEF SNAPMOUSE2DFLTBTN}
- if Assigned( Applet ) then
- Applet.DetachProc( WndProcSnapMouse2DfltBtn );
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END ShowMsg]
-
- //[procedure ShowMessage]
- procedure ShowMessage( const S: KOLString );
- begin
- ShowMsg( S, MB_OK or MB_SETFOREGROUND or MB_DEFBUTTON1 );
- end;
- //[END ShowMessage]
- {$ENDIF GDI}
-
- {$IFDEF WIN_GDI}
- //[procedure SpeakerBeep]
- procedure SpeakerBeep( Freq: Word; Duration: DWORD );
- begin
- {$ifdef win32}
- if WinVer >= wvNT then
- Windows.Beep( Freq, Duration )
- else
- begin
- if Freq < 18 then Exit;
- Freq := 1193181 div Freq;
- if Freq = 0 then Exit;
- asm
- mov al,0b6H
- out 43H,al
- mov ax,Freq
- //xchg al, ah
- out 42h,al
- xchg al, ah
- out 42h,al
- in al,61H
- or al,03H
- out 61H,al
- end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
- Sleep(Duration);
- asm
- in al,61H
- and al,0fcH
- out 61H,al
- end {$IFDEF F_P} [ 'EAX' ] {$ENDIF} ;
- end;
- {$endif win32}
- end;
- //[END SpeakerBeep]
- {$ENDIF WIN_GDI}
-
- {++}(*
- //[API FormatMessage]
- function FormatMessage; external kernel32 name 'FormatMessageA';
- *){--}
-
- //[FUNCTION SysErrorMessage]
- function SysErrorMessage(ErrorCode: Integer): KOLString;
- var
- Len: Integer;
- Buffer: array[0..255] of KOLChar;
- begin
- Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
- FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
- SizeOf(Buffer), nil);
- while (Len > 0) and ((Buffer[Len - 1] >= #0) and (Buffer[Len - 1] <= ' ')) do Dec(Len);
- SetString(Result, Buffer, Len);
- end;
- //[END SysErrorMessage]
- {$ENDIF WIN_GDI}
-
- //[function GetShiftState]
- function GetShiftState: DWORD;
- {$IFDEF WIN}
- const Buttons: array[0..6] of Byte = ( VK_SHIFT, VK_CONTROL, VK_MENU, VK_LBUTTON,
- VK_RBUTTON, VK_MBUTTON, VK_CAPITAL );
- Flags: array[0..6] of Byte = ( MK_SHIFT, MK_CONTROL, MK_ALT, MK_LBUTTON,
- MK_RBUTTON, MK_MBUTTON, MK_LOCK );
- var i, mask: Integer;
- {$ENDIF WIN} //todo: for Linux / GTK ?
- begin
- Result := 0;
- {$IFDEF WIN}
- mask := 1;
- for i := High( Buttons ) downto 0 do
- begin
- if GetKeyState( Buttons[ i ] ) and mask <> 0 then
- Result := Result or Flags[ i ];
- mask := $8000;
- end;
- {$ENDIF WIN}
- end;
- //[END GetShiftState]
-
- //[function MakeMethod]
- function MakeMethod( Data, Code: Pointer ): TMethod;
- begin
- Result.Data := Data;
- Result.Code := Code;
- end;
- //[END MakeMethod]
-
- //[FUNCTION MakeRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakeRect( Left, Top, Right, Bottom: Integer ): TRect; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result.Left := Left;
- Result.Top := Top;
- Result.Right:= Right;
- Result.Bottom := Bottom;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeRect]
-
- //[FUNCTION RectsEqual]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function RectsEqual( const R1, R2: TRect ): Boolean;
- begin
- Result := CompareMem( @R1, @R2, Sizeof( TRect ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END RectsEqual]
-
- //[function RectsIntersected]
- function RectsIntersected( const R1, R2: TRect ): Boolean;
- begin
- Result := ((R1.Left <= R2.Left) and (R1.Right > R2.Left ) or
- (R1.Left <= R2.Right) and (R1.Right >= R2.Right) or
- (R1.Left >= R2.Left) and (R1.Right <= R2.Right))
- and
- ((R1.Top <= R2.Top) and (R1.Bottom > R2.Top) or
- (R1.Top <= R2.Bottom) and (R1.Bottom >= R2.Bottom) or
- (R1.Top >= R2.Top) and (R1.Bottom <= R2.Bottom)) ;
- end;
- //[END RectsIntersected]
-
- //[FUNCTION PointInRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function PointInRect( const P: TPoint; const R: TRect ): Boolean;
- begin
- Result := (P.x >= R.Left) and (P.x < R.Right)
- and (P.y >= R.Top) and (P.y < R.Bottom);
- end;
- {$ENDIF ASM_VERSION}
- //[END PointInRect]
-
- //[FUNCTION OffsetPoint]
- {$IFDEF ASM_VERSION}
- function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
- asm
- ADD EDX, [EAX].TPoint.X
- ADD ECX, [EAX].TPoint.Y
- MOV EAX, [Result]
- MOV [EAX].TPoint.X, EDX
- MOV [EAX].TPoint.Y, ECX
- end;
- {$ELSE ASM_VERSION} // Pascal
- function OffsetPoint( const T: TPoint; dX, dY: Integer ): TPoint;
- begin
- Result := MakePoint( T.X + dX, T.Y + dY );
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION OffsetSmallPoint]
- {$IFDEF ASM_VERSION}
- function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
- asm
- SHL EDX, 16
- SHLD ECX, EDX, 16
- CALL @@1
- @@1:
- ROL EAX, 16
- ROL ECX, 16
- ADD AX, CX
- end;
- {$ELSE ASM_VERSION} // Pascal
- function OffsetSmallPoint( const T: TSmallPoint; dX, dY: SmallInt ): TSmallPoint;
- begin
- Result.x := T.x + dX;
- Result.y := T.y + dY;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_VERSION}
- function Point2SmallPoint( const T: TPoint ): TSmallPoint;
- asm
- XCHG EDX, EAX
- MOV EAX, [EDX].TPoint.Y-2
- MOV AX, word ptr [EDX].TPoint.X
- end;
- {$ELSE ASM_VERSION} // Pascal
- function Point2SmallPoint( const T: TPoint ): TSmallPoint;
- begin
- Result.x := T.X;
- Result.y := T.Y;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_VERSION}
- function SmallPoint2Point( const T: TSmallPoint ): TPoint;
- asm
- MOVSX ECX, AX
- MOV [EDX].TPoint.X, ECX
- SAR EAX, 16
- MOV [EDX].TPoint.Y, EAX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function SmallPoint2Point( const T: TSmallPoint ): TPoint;
- begin
- Result := MakePoint( T.x, T.y );
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION MakePoint]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakePoint( X, Y: Integer ): TPoint;
- begin
- Result.x := X;
- Result.y := Y;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakePoint]
-
- {$IFDEF ASM_VERSION}
- function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
- asm
- SHL EAX, 16
- SHRD EAX, EDX, 16
- end;
- {$ELSE ASM_VERSION} // Pascal
- function MakeSmallPoint( X, Y: Integer ): TSmallPoint;
- begin
- Result.x := X;
- Result.y := Y;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION MakeFlags]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakeFlags( FlgSet: PDWORD; FlgArray: array of Integer): Integer;
- var I : Integer;
- Mask : DWORD;
- begin
- Result := 0;
- Mask := FlgSet^;
- for I := 0 to High( FlgArray ) do
- begin
- if (FlgArray[ I ] < 0) and not LongBool( Mask and 1 ) then
- Result := Result or not FlgArray[ I ]
- else
- if (FlgArray[ I ] >= 0) and LongBool( Mask and 1 ) then
- Result := Result or FlgArray[ I ];
- Mask := Mask shr 1;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeFlags]
-
- function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
- begin
- Result.FromDate := D1;
- Result.ToDate := D2;
- end;
-
- //[procedure Swap]
- {$IFDEF ASM_VERSION}
- procedure Swap( var X, Y: Integer );
- asm
- MOV ECX, [EDX]
- XCHG ECX, [EAX]
- MOV [EDX], ECX
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure Swap( var X, Y: Integer );
- var Tmp: Integer;
- begin
- Tmp := X;
- X := Y;
- Y := Tmp;
- end;
- {$ENDIF ASM_VERSION}
- //[END Swap]
-
- //[function Min]
- {$IFDEF ASM_VERSION}
- function Min( X, Y: Integer ): Integer;
- asm
- {$IFDEF F_P}
- MOV EAX, [X]
- MOV EDX, [Y]
- {$ENDIF F_P}
- {$IFDEF USE_CMOV}
- CMP EAX, EDX
- CMOVG EAX, EDX
- {$ELSE}
- CMP EAX, EDX
- JLE @@exit
- MOV EAX, EDX
- @@exit:
- {$ENDIF}
- end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function Min( X, Y: Integer ): Integer;
- begin
- if X < Y then
- Result:=X
- else
- Result:=Y;
- end;
- {$ENDIF ASM_VERSION}
- //[END Min]
-
- //[function Max]
- {$IFDEF ASM_VERSION}
- function Max( X, Y: Integer ): Integer;
- asm
- {$IFDEF F_P}
- MOV EAX, [X]
- MOV EDX, [Y]
- {$ENDIF F_P}
- {$IFDEF USE_CMOV}
- CMP EAX, EDX
- CMOVL EAX, EDX
- {$ELSE}
- CMP EAX, EDX
- JGE @@exit
- MOV EAX, EDX
- @@exit:
- {$ENDIF}
- end {$IFDEF F_P} [ 'EAX', 'EDX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function Max( X, Y: Integer ): Integer;
- begin
- if X > Y then
- Result:=X
- else
- Result:=Y;
- end;
- {$ENDIF ASM_VERSION}
- //[END Max]
-
- {$IFDEF REDEFINE_ABS}
- //[function Abs]
- function Abs( X: Integer ): Integer;
- asm
- {$IFDEF F_P}
- MOV EAX, [X]
- {$ENDIF F_P}
- cdq
- xor eax, edx
- sub eax, edx
- end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
- //[END Abs]
- {$ENDIF}
-
- //[function Sgn]
- {$IFDEF ASM_VERSION}
- function Sgn( X: Integer ): Integer;
- asm
- CMP EAX, 0
- {$IFDEF USE_CMOV}
- MOV EDX, -1
- CMOVL EAX, EDX
- MOV EDX, 1
- CMOVG EAX, EDX
- {$ELSE}
- JZ @@exit
- MOV EAX, 1
- JG @@exit
- MOV EAX, -1
- @@exit:
- {$ENDIF}
- end;
- {$ELSE ASM_VERSION} //Pascal
- function Sgn( X: Integer ): Integer;
- begin
- if X > 0 then
- Result:=1
- else
- Result:=-1;
- end;
- {$ENDIF ASM_VERSION}
- //[END Sgn]
-
- //[function iSqrt]
- function iSQRT( X: Integer ): Integer;
- {$IFDEF _D4orHigher}
- // new version is more efficient but code is not compatible with older compilers
- var I, N: Int64;
- begin
- Result := 0;
- while Result < X do
- begin
- I := 1;
- while I > 0 do
- begin
- N := (Result + I) * (Result + I);
- if N > X then
- begin
- I := I shr 1;
- break;
- end
- else
- if N = X then
- begin
- Result := Result + I;
- Exit;
- end;
- I := I * 2;
- end;
- if I <= 0 then Exit;
- Result := Result + I;
- end;
- end;
- {$ELSE _D3 or below or FPC1}
- var m, y, b: DWORD;
- begin
- m := $40000000;
- y := 0;
- while m <> 0 do // 16 times
- begin
- b := y or m;
- y := y shr 1;
- if x >= b then
- begin
- x := x - b;
- y := y or m;
- end;
- m := m shr 2;
- end;
- Result := y;
- end;
- {$ENDIF}
- //[END iSqrt]
-
- function iCbrt( X: DWORD ): Integer;
- var s: Integer;
- y, b: DWORD;
- begin
- s := 30;
- y := 0;
- while s >= 0 do // 11 times
- begin
- y := 2 * y;
- b := (3 * y * (y+1) + 1) shl s;
- s := s - 3;
- if x >= b then
- begin
- x := x - b;
- y := y + 1;
- end;
- end;
- Result := y;
- end;
- {$IFDEF WIN_GDI}
-
- {$IFDEF ASM_DC}
- //[PROCEDURE StartDC]
- procedure StartDC;
- asm
- { <- EBX : PBitmap
- -> EAX = dc
- [ESP+8] = var dc
- [ESP+4] = var SaveBmp
- }
- PUSH 0
- CALL CreateCompatibleDC
- POP EDX
- PUSH EAX
- PUSH EDX
- MOV EAX, EBX
- CALL [EBX].TBitmap.fDetachCanvas
- MOV EAX, EBX
- CALL TBitmap.GetHandle
- PUSH EAX
- PUSH dword ptr [ESP+8]
- CALL SelectObject
- POP EDX
- PUSH EAX
- PUSH EDX
- MOV EAX, [ESP+8]
- end;
- //[END StartDC]
-
- //[procedure FinishDC]
- procedure FinishDC;
- asm
- POP ECX
- POP EAX
- POP EDX
- PUSH ECX
- PUSH EDX
- PUSH EAX
- PUSH EDX
- CALL SelectObject
- CALL DeleteDC
- end;
- //[END FinishDC]
- {$ENDIF ASM_DC}
-
- //[function EnumDynHandlers FORWARD DECLARATION]
- function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- forward;
-
- {$ENDIF WIN_GDI}
- //[procedure DummyObjProc]
- procedure DummyObjProc( Sender: PObj );
- begin
- end;
-
- //[procedure DummyObjProcParam]
- procedure DummyObjProcParam( Sender: PObj; Param: Pointer );
- begin
- end;
-
- //[procedure DummyPaintProc]
- procedure DummyPaintProc( Sender: PControl; DC: HDC );
- begin
- end;
- {$IFDEF WIN}
-
- {$ENDIF WIN}
- {-}
- { _TObj }
-
- //[procedure Free_And_Nil]
- procedure Free_And_Nil( var Obj );
- var Obj1: PObj;
- begin
- Obj1 := PObj( Obj );
- Pointer( Obj ) := nil;
- Obj1.Free;
- end;
-
- //[procedure _TObj.Init]
- procedure _TObj.Init;
- begin
- {$IFDEF _D2orD3}
- FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, 0 );
- {$ENDIF}
- end;
-
- //[function _TObj.VmtAddr]
- function _TObj.VmtAddr: Pointer;
- asm
- {$ifdef cpuarm}
- ldr r0,[r0]
- {$else}
- MOV EAX, [EAX]
- {$endif cpuarm}
- end;
-
- { TObj }
-
- class function TObj.AncestorOfObject(Obj: Pointer): Boolean;
- asm
- {$ifdef cpuarm}
- mov r0,#0
- {$else}
- MOV ECX, [EAX]
- MOV EAX, EDX
- JMP @@loop1
- @@loop:
- MOV EAX,[EAX]
- @@loop1:
- TEST EAX,EAX
- JE @@exit
- CMP EAX,ECX
- JNE @@loop
- @@success:
- MOV AL,1
- @@exit:
- {$endif cpuarm}
- end;
-
- {+}
-
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- constructor TObj.Create;
- begin
- Init;
- {++}(* inherited; *){--}
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF OLD_REFCOUNT}
- //[procedure TObj.DoDestroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TObj.DoDestroy;
- begin
- {$IFDEF OLD_REFCOUNT}
- if fRefCount > 0 then
- begin
- if not LongBool( fRefCount and 1) then
- Dec( fRefCount, 2 );
- RefDec;
- end
- else
- Self.Destroy;
- if fRefCount <> 0 then
- begin
- if not LongBool( fRefCount and 1) then
- Dec( fRefCount );
- end
- else
- Self.Destroy;
- {$ELSE}
- if fRefCount > 0 then
- RefDec
- else
- Self.Destroy;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF OLD_REFCOUNT}
-
- //[procedure TObj.RefDec]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TObj.RefDec: Integer;
- begin
- Result := 0; // stop Delphi alerting the Warning
- if @ Self = nil then Exit;
- Dec( fRefCount, 2 );
- {$IFDEF OLD_REFCOUNT}
- if (fRefCount < 0) and LongBool(fRefCount and 1) then
- {$ifdef FPC}
- Dispose(PObj(@Self),Destroy);
- {$else}
- Destroy;
- {$endif FPC}
- {$ELSE}
- if fRefCount < 0 then
- {$ifdef FPC}
- Dispose(PObj(@Self),Destroy);
- {$else}
- Destroy;
- {$endif FPC}
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TObj.RefInc]
- procedure TObj.RefInc;
- begin
- Inc( fRefCount, 2 );
- end;
-
- {-}
- //[function TObj.VmtAddr]
- function TObj.VmtAddr: Pointer;
- asm
- {$ifdef cpuarm}
- ldr r0,[r0,#-4]
- {$else}
- MOV EAX, [EAX - 4]
- {$endif cpuarm}
- end;
-
- //[function TObj.InstanceSize]
- function TObj.InstanceSize: Integer;
- asm
- {$ifdef cpuarm}
- ldr r0,[r0]
- ldr r0,[r0,#-4]
- {$else}
- MOV EAX, [EAX]
- MOV EAX,[EAX-4]
- {$endif cpuarm}
- end;
- {+}
-
- {$IFDEF OLD_FREE}
- //[procedure TObj.Free]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- procedure TObj.Free;
- begin
- //if @ Self <> nil then
- RefDec;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF OLD_FREE}
-
- {$UNDEF ASM_LOCAL}
- {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
- {$IFDEF CRASH_DEBUG} {$UNDEF ASM_LOCAL} {$ENDIF}
- {$IFDEF ASM_DEBUG} {$DEFINE ASM_LOCAL} {$ENDIF}
-
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- destructor TObj.Destroy;
- begin
- Final;
-
- {$IFDEF DEBUG_ENDSESSION}
- if EndSession_Initiated then
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'FINALLED: ' + Int2Hex( DWORD( @ Self )
- {$IFDEF USE_NAMES}
- + ' (name:' + FName + ')'
- {$ENDIF}
- , 8 ) );
- {$ENDIF}
- {$IFDEF USE_NAMES}
- fName := '';
- if fNamedObjList <> nil then Free_And_Nil(fNamedObjList);
- {$ENDIF}
- {-}
- //Dispose( @Self );
- {$IFDEF CRASH_DEBUG}
- FillChar( Pointer( Integer(@Self) + 4 )^, Sizeof( Self ) - 4, #$DD );
- {$ENDIF}
- {$ifndef FPC}
- FreeMem( @ Self );
- {$endif FPC}
- {+} {++}(*
- inherited; *){--}
- end;
- {$ENDIF ASM_VERSION}
-
- {++}(*
- //[procedure TObj.Init]
- procedure TObj.Init;
- begin
-
- end;
- *){--}
-
- //[procedure TObj.Final]
- {$IFDEF ASM_VERSION}
- procedure TObj.Final;
- asm //cmd //opd
- PUSH EBX
- XCHG EBX, EAX
- XOR ECX, ECX
- XCHG ECX, [EBX].fOnDestroy.TMethod.Code
- JECXZ @@freeloop
- MOV EDX, EBX
- MOV EAX, [EDX].fOnDestroy.TMethod.Data
- CALL ECX
- @@freeloop:
- MOV ECX, [EBX].fAutoFree
- JECXZ @@eloop
- MOV EDX, [ECX].TList.fItems
- MOV ECX, [ECX].TList.fCount
- JECXZ @@eloop
- MOV EAX, [EDX+ECX*4-4]
- MOV EDX, [EDX+ECX*4-8]
- PUSH EAX
- PUSH EDX
- MOV EAX, [EBX].fAutoFree
- LEA EDX, [ECX-2]
- XOR ECX, ECX
- MOV CL, 2
- CALL TList.DeleteRange
- POP EDX
- POP EAX
- CALL EDX
- JMP @@freeloop
- @@eloop:
- XOR EAX, EAX
- XCHG [EBX].fAutoFree, EAX
- CALL TObj.RefDec
- @@exit:
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TObj.Final;
- var N: Integer;
- ProcMethod: TMethod;
- {$IFDEF _D2orD3}
- Proc: TObjectMethod;
- {$ELSE}
- Proc: TObjectMethod Absolute ProcMethod;
- {$ENDIF}
- begin
- if Assigned( fOnDestroy ) then
- begin
- fOnDestroy( @Self );
- fOnDestroy := nil;
- end;
- while (fAutoFree <> nil) and (fAutoFree.fCount > 0) do
- begin
- N := fAutoFree.fCount - 2;
- ProcMethod.Code := fAutoFree.fItems[ N ];
- ProcMethod.Data := fAutoFree.fItems[ N + 1 ];
- fAutoFree.DeleteRange( N, 2 );
- {-}
- {$IFDEF _D2orD3}
- Proc := TObjectMethod( ProcMethod );
- {$ENDIF}
- Proc;
- {+}{++}(*
- asm
- MOV EAX, [ProcMethod.Data]
- {$IFDEF F_P}
- PUSH EAX
- {$ENDIF F_P}
- MOV ECX, [ProcMethod.Code]
- CALL ECX
- end {$IFDEF F_P}[ 'EAX', 'EDX', 'ECX' ]{$ENDIF};
- *){--}
- end;
- fAutoFree.Free;
- fAutoFree := nil;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TObj.Add2AutoFree]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TObj.Add2AutoFree(Obj: PObj);
- begin
- if fAutoFree = nil then
- fAutoFree := NewList;
- fAutoFree.Insert( 0, Obj );
- fAutoFree.Insert( 0, Pointer( @TObj.RefDec ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TObj.Add2AutoFreeEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TObj.Add2AutoFreeEx( Proc: TObjectMethod );
- {$IFDEF F_P}
- var Ptr1, Ptr2: Pointer;
- {$ENDIF F_P}
- begin
- if fAutoFree = nil then
- fAutoFree := NewList;
- {$IFDEF F_P}
- asm
- MOV EAX, [Proc]
- MOV [Ptr1], EAX
- MOV EAX, [Proc+4]
- MOV [Ptr2], EAX
- end [ 'EAX' ];
- fAutoFree.Insert( 0, Ptr2 );
- fAutoFree.Insert( 0, Ptr1 );
- {$ELSE DELPHI}
- fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Data ) );
- fAutoFree.Insert( 0, Pointer( TMethod( Proc ).Code ) );
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TObj.RemoveFromAutoFree]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- procedure TObj.RemoveFromAutoFree(Obj: PObj);
- var i: Integer;
- begin
- if fAutoFree <> nil then
- begin
- i := fAutoFree.IndexOf( Obj );
- if i >= 0 then
- begin
- fAutoFree.DeleteRange( i and not 1, 2 );
- if fAutoFree.Count = 0 then
- Free_And_Nil( fAutoFree );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- procedure TObj.RemoveFromAutoFreeEx(Proc: TObjectMethod);
- var i: Integer;
- begin
- if fAutoFree <> nil then
- begin
- for i := 0 to fAutoFree.Count-2 do
- if (fAutoFree.Items[ i ] = TMethod( Proc ).Data) and
- (fAutoFree.Items[ i+1 ] = TMethod( Proc ).Code) then
- begin
- fAutoFree.Delete( i );
- fAutoFree.Delete( i );
- break;
- end;
- end;
- end;
-
- {$IFDEF USE_NAMES}
- procedure TObj.SetName( NewOwnerObj: PObj; const NewName: String );
- {$IFDEF UNIQUE_NAMES}
- var i: Integer;
- {$ENDIF}
- begin
- if (FOwnerObj <> nil) then
- if FOwnerObj <> NewOwnerObj then
- begin
- FOwnerObj.fNamedObjList.Remove( @ Self );
- end;
- FOwnerObj := NewOwnerObj;
- if NewOwnerObj = nil then
- begin
- if NewName = '' then
- begin
- fName := '';
- Exit;
- end;
- // çäåñü òîò ñëó÷àé, êîãäà â ïðèëîæåíèè áåç Applet'à óñòàíàâëèâàåòñÿ
- // èìÿ äëÿ ãëàâíîé ôîðìû (íàâåðíîå)
- FOwnerObj := @ Self; // âëàäåëüöåì ñïèñêà èìåíîâàííûõ îáúåêòîâ ñòàíîâèòñÿ
- // ñàì îáúåêò. Äëÿ âûøåîçíà÷åííîãî ñëó÷àÿ - ãëàâíàÿ ôîðìà äåðæèò ñåáÿ è
- // äðóãèå ôîðìû.
- end;
- if FOwnerObj.fNamedObjList = nil then
- FOwnerObj.fNamedObjList := NewList;
- {$IFDEF UNIQUE_NAMES}
- for i := 0 to FOwnerObj.fNamedObjList.Count-1 do
- begin
- if PObj( FOwnerObj.fNamedObjList.Items[ i ] ).FName = NewName then
- begin
- NewName := '';
- break;
- end;
- end;
- {$ENDIF}
- FName := NewName;
- if FName = '' then
- FOwnerObj.fNamedObjList.Remove( @ Self )
- else
- if FOwnerObj.fNamedObjList.IndexOf( @ Self ) < 0 then
- FOwnerObj.fNamedObjList.Add( @ Self );
- end;
-
- function TObj.FindObj(const ObjName: string): PObj;
- var i: Integer;
- Obj: PObj;
- begin
- if fNamedObjList <> nil then
- for i := 0 to fNamedObjList.Count-1 do
- begin
- Obj := fNamedObjList.Items[ i ];
- if ObjName = Obj.FName then
- begin
- Result := Obj; Exit;
- end;
- end;
- Result := nil;
- end;
- {$ENDIF}
-
- { TList }
-
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_TLIST}
- {$IFDEF TLIST_FAST}
- {$UNDEF ASM_TLIST}
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF USE_CONSTRUCTORS}
- procedure TList.Init;
- begin
- {$IFDEF _D2orD3}
- inherited;
- {$ENDIF}
- fAddBy := 4;
- {$IFDEF TLIST_FAST}
- {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
- fUseBlocks := TRUE;
- {$ENDIF}
- {$ENDIF}
- end;
-
- //[function NewList]
- function NewList: PList;
- begin
- New( Result, Create );
- //Result.fAddBy := 4;
- end;
- //[END NewList]
-
- {$ELSE not_USE_CONSTRUCTORS}
- //[function NewList]
- function NewList: PList;
- begin
- {-}
- New( Result, Create );
- {+} {++}(* Result := PList.Create; *){--}
- Result.fAddBy := 4;
- {$IFDEF TLIST_FAST}
- {$IFNDEF DFLT_TLIST_NOUSE_BLOCKS} // for debug only
- Result.fUseBlocks := TRUE;
- {$ENDIF}
- {$ENDIF}
- end;
- //[END NewList]
- {$ENDIF USE_CONSTRUCTORS}
-
- //[procedure TList.Init]
- {$IFDEF _D4orHigher}
- function NewListInit( const AItems: array of Pointer ): PList;
- var i: Integer;
- begin
- Result := NewList;
- Result.Capacity := Length( AItems );
- for i := 0 to High( AItems ) do
- Result.Add( AItems[ i ] );
- end;
- {$ENDIF}
-
- //[procedure HelpFastIncNum2Els]
- {$IFDEF ASM_VERSION}
- procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );
- asm
- PUSH ESI
- PUSH EDI
- {$IFDEF F_P}
- MOV ESI, [DataArray]
- MOV EDX, [Value]
- MOV ECX, [Count]
- {$ELSE DELPHI}
- MOV ESI, EAX
- {$ENDIF F_P/DELPHI}
- MOV EDI, ESI
- CLD
-
- @@1:
- LODSD
- ADD EAX, EDX
- STOSD
- LOOP @@1
-
- POP EDI
- POP ESI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- procedure HelpFastIncNum2Els( DataArray: Pointer; Value, Count: Integer );
- begin
- while Count > 0 do begin
- Inc(PInteger(DataArray)^, Value);
- Inc(PInteger(DataArray));
- Dec(Count);
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END HelpFastIncNum2Els]
-
- //[procedure FastIncNum2Elements]
- procedure FastIncNum2Elements( List: TList; FromIdx, Count, Value: Integer );
- begin
- HelpFastIncNum2Els( @List.fItems[ FromIdx ], Value, Count );
- end;
-
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TList.Destroy;
- begin
- Clear;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.Release]
- {$IFDEF ASM_TLIST}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.Release;
- var I: Integer;
- {$IFDEF TLIST_FAST}
- BlockStart: PDWORD;
- j, CountCurrent: Integer;
- {$ENDIF}
- begin
- if @ Self = nil then Exit;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- for i := 0 to fBlockList.Count div 2 - 1 do
- begin
- BlockStart := fBlockList.fItems[ i*2 ];
- CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
- for j := 0 to CountCurrent-1 do
- begin
- if BlockStart^ <> 0 then
- FreeMem( Pointer( BlockStart^ ) );
- inc( BlockStart );
- end;
- end;
- end
- else
- {$ENDIF}
- for I := 0 to fCount - 1 do
- if fItems[ I ] <> nil then
- FreeMem( fItems[ I ] );
- Free;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.ReleaseObjects]
- procedure TList.ReleaseObjects;
- var I: Integer;
- {$IFDEF TLIST_FAST}
- BlockStart: PDWORD;
- j, CountCurrent: Integer;
- {$ENDIF}
- begin
- if @ Self = nil then Exit;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- for i := 0 to fBlockList.Count div 2 - 1 do
- begin
- BlockStart := fBlockList.fItems[ i*2 ];
- CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
- for j := 0 to CountCurrent-1 do
- begin
- if BlockStart^ <> 0 then
- PObj( Pointer( BlockStart^ ) ).Free;
- inc( BlockStart );
- end;
- end;
- end
- else
- {$ENDIF}
- for I := fCount-1 downto 0 do
- PObj( fItems[ I ] ).Free;
- Free;
- end;
-
- //[procedure TList.SetCapacity]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- //var NewItems: PPointerList;
- procedure TList.SetCapacity( Value: Integer );
- begin
- {$IFDEF TLIST_FAST}
- if fUseBlocks and (Assigned( fBlockList ) or (Value > 256)) then
- begin
- fCapacity := Value;
- end
- else
- {$ENDIF}
- begin
- if Value < Count then
- Value := Count;
- if Value = fCapacity then Exit;
- ReallocMem( fItems, Value * Sizeof( Pointer ) );
- fCapacity := Value;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.Clear]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.Clear;
- {$IFDEF TLIST_FAST}
- var i: Integer;
- {$ENDIF}
- begin
- if fItems <> nil then
- FreeMem( fItems );
- fItems := nil;
- fCount := 0;
- fCapacity := 0;
- {$IFDEF TLIST_FAST}
- if fBlockList <> nil then
- for i := 0 to fBlockList.Count div 2 - 1 do
- FreeMem(fBlockList.Items[ i*2 ]);
- Free_And_Nil( fBlockList );
- fLastKnownBlockIdx := 0;
- fLastKnownCountBefore := 0;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.SetAddBy]
- procedure TList.SetAddBy(Value: Integer);
- begin
- if Value < 1 then Value := 1;
- fAddBy := Value;
- end;
-
- //[procedure TList.Add]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.Add( Value: Pointer );
- {$IFDEF TLIST_FAST}
- var LastBlockCount: Integer;
- LastBlockStart: Pointer;
- {$ENDIF}
- begin
- {$IFDEF TLIST_FAST}
- if fUseBlocks and ((fCount >= 256) or Assigned( fBlockList )) then
- begin
- if fBlockList = nil then
- begin
- fBlockList := NewList;
- fBlockList.fUseBlocks := FALSE;
- fBlockList.Add( fItems );
- fBlockList.Add( Pointer( fCount ) );
- fItems := nil;
- end;
- if fBlockList.fCount = 0 then
- begin
- fBlockList.Add( nil );
- fBlockList.Add( nil );
- LastBlockCount := 0;
- end
- else
- begin
- LastBlockCount := Integer( fBlockList.fItems[ fBlockList.fCount-1 ] );
- if LastBlockCount >= 256 then
- begin
- fBlockList.Add( nil );
- fBlockList.Add( nil );
- LastBlockCount := 0;
- end;
- end;
- LastBlockStart := fBlockList.Items[ fBlockList.fCount-2 ];
- if LastBlockStart = nil then
- begin
- GetMem( LastBlockStart, 256 * Sizeof( Pointer ) );
- fBlockList.Items[ fBlockList.fCount-2 ] := LastBlockStart;
- end;
- fBlockList.Items[ fBlockList.fCount-1 ] := Pointer( LastBlockCount+1 );
- PDWORD( Integer(LastBlockStart) + Sizeof(Pointer)*LastBlockCount )^ :=
- DWORD( Value );
- end
- else
- {$ENDIF}
- begin
- if fCapacity <= fCount then
- begin
- if fAddBy <= 0 then
- Capacity := fCount + Min( 1000, fCount div 4 + 1 )
- else
- Capacity := fCount + fAddBy;
- end;
- fItems[ fCount ] := Value;
- end;
- Inc( fCount );
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF _D4orHigher}
- procedure TList.AddItems(const AItems: array of Pointer);
- var i: Integer;
- begin
- Capacity := Count + Length( AItems );
- for i := 0 to High( AItems ) do
- Add( AItems[ i ] );
- end;
- {$ENDIF}
-
- //[procedure TList.Delete]
- procedure TList.Delete( Idx: Integer );
- begin
- DeleteRange( Idx, 1 );
- end;
-
- //[procedure TList.DeleteRange]
- {$IFDEF ASM_TLIST}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.DeleteRange(Idx, Len: Integer);
- {$IFDEF TLIST_FAST}
- var i, DelFromBlock: Integer;
- CountBefore, CountCurrent: Integer;
- BlockStart: Pointer;
- {$ENDIF}
- begin
- if Len <= 0 then Exit;
- if Idx >= Count then Exit;
- Assert( (Idx >= 0), 'TList.DeleteRange: index out of bounds' );
- if DWORD( Idx + Len ) > DWORD( Count ) then
- Len := Count - Idx;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- CountBefore := 0;
- i := 0;
- if (fLastKnownBlockIdx > 0) and
- (Idx >= fLastKnownCountBefore) then
- begin
- i := fLastKnownBlockIdx;
- CountBefore := fLastKnownCountBefore;
- end;
- while i < fBlockList.fCount div 2 do
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
- if (Idx >= CountBefore) and (Idx < CountBefore + CountCurrent) then
- begin
- DelFromBlock := CountBefore + CountCurrent - Idx;
- if DelFromBlock > Len then
- DelFromBlock := Len;
- if DelFromBlock < CountCurrent then
- begin
- move( Pointer( Integer( BlockStart ) + (Idx - CountBefore + DelFromBlock) * Sizeof( Pointer ) )^,
- Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^,
- (CountCurrent - (Idx - CountBefore) - DelFromBlock) * Sizeof( Pointer ) );
- dec( CountCurrent, DelFromBlock );
- fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent );
- dec( fCount, DelFromBlock );
- dec( Len, DelFromBlock );
- if Len <= 0 then Exit;
- end
- else
- begin // delete entire block
- FreeMem( BlockStart );
- fBlockList.DeleteRange( i * 2, 2 );
- dec( fCount, CountCurrent );
- dec( Len, CountCurrent );
- if Len <= 0 then Exit;
- CountCurrent := 0;
- dec( i );
- end;
- end;
- inc( i );
- inc( CountBefore, CountCurrent );
- end;
- end
- else
- {$ENDIF}
- begin
- Move( fItems[ Idx + Len ], fItems[ Idx ], Sizeof( Pointer ) * (Count - Idx - Len) );
- Dec( fCount, Len );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.Remove]
- procedure TList.Remove(Value: Pointer);
- var I: Integer;
- begin
- I := IndexOf( Value );
- if I >= 0 then
- Delete( I );
- end;
-
- function TList.ItemAddress(Idx: Integer): Pointer;
- {$IFDEF TLIST_FAST}
- var i: Integer;
- BlockStart: Pointer;
- CountBefore, CountCurrent: Integer;
- {$ENDIF}
- begin
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- CountBefore := 0;
- i := 0;
- if (fLastKnownBlockIdx > 0) and
- (Idx >= fLastKnownCountBefore) then
- begin
- CountBefore := fLastKnownCountBefore;
- i := fLastKnownBlockIdx;
- end;
- CountCurrent := CountBefore + Integer( fBlockList.fItems[ i*2+1 ] );
- if Idx - CountCurrent > fCount - CountCurrent then
- begin // ïîèñê â îáðàòíîì íàïðàâëåíèè ìîæåò îêàçàòüñÿ áûñòðåå
- CountBefore := fCount;
- i := fBlockList.fCount div 2 - 1;
- while TRUE do
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
- if (CountBefore - CountCurrent <= Idx) and (Idx < CountBefore) then
- begin
- Result := Pointer( Integer( BlockStart ) +
- (Idx - (CountBefore - CountCurrent))*Sizeof( Pointer ) );
- Exit;
- end;
- dec( CountBefore, CountCurrent );
- dec( i );
- end;
- end;
- while TRUE { i < fBlockList.Count div 2 } do
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
- if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
- begin
- Result := Pointer( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) );
- Exit;
- end;
- inc( CountBefore, CountCurrent );
- inc( i );
- end;
- end
- else
- {$ENDIF}
- Result := Pointer( cardinal( fItems ) + cardinal(Idx) * Sizeof( Pointer ) );
- end;
-
- //[procedure TList.Put]
- {$IFDEF ASM_VERSION}
- procedure TList.Put( Idx: Integer; Value: Pointer );
- asm
- TEST EDX, EDX
- JL @@exit
- CMP EDX, [EAX].fCount
- JGE @@exit
- PUSH ESI
- MOV ESI, ECX
- {$IFDEF TLIST_FAST}
- CMP [EAX].fUseBlocks, 0
- JZ @@old
- MOV ECX, [EAX].fBlockList
- JECXZ @@old
- PUSH EBX
- PUSH ESI
- PUSH EDI
- PUSH EBP
- XCHG EBX, EAX // EBX == @Self
- XOR ECX, ECX // CountBefore := 0;
- XOR EAX, EAX // i := 0;
- CMP [EBX].fLastKnownBlockIdx, 0
- JLE @@1
- CMP EDX, [EBX].fLastKnownCountBefore
- JL @@1
- MOV ECX, [EBX].fLastKnownCountBefore
- MOV EAX, [EBX].fLastKnownBlockIdx
- @@1:
- MOV ESI, [EBX].fBlockList
- MOV ESI, [ESI].fItems
- MOV EDI, [ESI+EAX*8] // EDI = BlockStart
- MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent
- CMP ECX, EDX
- JG @@next
- LEA EBP, [ECX+ESI]
- CMP EDX, EBP
- JGE @@next
- MOV [EBX].fLastKnownBlockIdx, EAX
- MOV [EBX].fLastKnownCountBefore, ECX
- SUB EDX, ECX
- LEA EAX, [EDI+EDX*4]
- POP EBP
- POP EDI
- POP ESI
- POP EBX
- MOV [EAX], ESI
- POP ESI
- RET
- @@next:
- ADD ECX, ESI
- INC EAX
- JMP @@1
- @@old:
- {$ENDIF}
- MOV EAX, [EAX].fItems
- MOV [EAX+EDX*4], ESI
- POP ESI
- @@exit:
- end;
- {$ELSE not ASM_VERSION}
- procedure TList.Put( Idx: Integer; Value: Pointer );
- {$IFDEF TLIST_FAST}
- var i: Integer;
- BlockStart: Pointer;
- CountBefore, CountCurrent: Integer;
- {$ENDIF}
- begin
- if Idx < 0 then Exit;
- if Idx >= Count then Exit;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- CountBefore := 0;
- i := 0;
- if (fLastKnownBlockIdx > 0) and
- (Idx >= fLastKnownCountBefore) then
- begin
- i := fLastKnownBlockIdx;
- CountBefore := fLastKnownCountBefore;
- end;
- while i < fBlockList.fCount div 2 do
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
- if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
- begin
- fLastKnownBlockIdx := i;
- fLastKnownCountBefore := CountBefore;
- PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ :=
- DWORD( Value );
- Exit;
- end;
- inc( CountBefore, CountCurrent );
- inc( i );
- end;
- end
- else
- {$ENDIF}
- fItems[ Idx ] := Value;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TList.Get]
- {$IFDEF ASM_VERSION}
- function TList.Get( Idx: Integer ): Pointer;
- asm
- TEST EDX, EDX
- JL @@ret_nil
- CMP EDX, [EAX].fCount
- JGE @@ret_nil
- {$IFDEF TLIST_FAST}
- CMP [EAX].fUseBlocks, 0
- JZ @@old
- MOV ECX, [EAX].fBlockList
- JECXZ @@old
- PUSH EBX
- PUSH ESI
- PUSH EDI
- PUSH EBP
- XCHG EBX, EAX // EBX == @Self
- XOR ECX, ECX // CountBefore := 0;
- XOR EAX, EAX // i := 0;
- CMP [EBX].fLastKnownBlockIdx, 0
- JLE @@1
- CMP EDX, [EBX].fLastKnownCountBefore
- JL @@1
- MOV ECX, [EBX].fLastKnownCountBefore
- MOV EAX, [EBX].fLastKnownBlockIdx
- @@1:
- MOV ESI, [EBX].fBlockList
- MOV ESI, [ESI].fItems
- MOV EDI, [ESI+EAX*8] // EDI = BlockStart
- MOV ESI, [ESI+EAX*8+4] // ESI = CountCurrent
- CMP ECX, EDX
- JG @@next
- LEA EBP, [ECX+ESI]
- CMP EDX, EBP
- JGE @@next
- MOV [EBX].fLastKnownBlockIdx, EAX
- MOV [EBX].fLastKnownCountBefore, ECX
- SUB EDX, ECX
- MOV EAX, [EDI+EDX*4]
- POP EBP
- POP EDI
- POP ESI
- POP EBX
- RET
- @@next:
- ADD ECX, ESI
- INC EAX
- JMP @@1
- @@old:
- {$ENDIF}
- MOV EAX, [EAX].fItems
- MOV EAX, [EAX+EDX*4]
- RET
- @@ret_nil:
- XOR EAX, EAX
- end;
- {$ELSE not ASM_VERSION}
- function TList.Get( Idx: Integer ): Pointer;
- {$IFDEF TLIST_FAST}
- var i: Integer;
- BlockStart: Pointer;
- CountBefore, CountCurrent: Integer;
- {$ENDIF}
- begin
- Result := nil;
- if Idx < 0 then Exit;
- if Idx >= fCount then Exit;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- CountBefore := 0;
- i := 0;
- if (fLastKnownBlockIdx > 0) and
- (Idx >= fLastKnownCountBefore) then
- begin
- i := fLastKnownBlockIdx;
- CountBefore := fLastKnownCountBefore;
- end;
- while {i < fBlockList.fCount div 2} TRUE do
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ i * 2 + 1 ] );
- if (CountBefore <= Idx) and (Idx < CountBefore + CountCurrent) then
- begin
- fLastKnownBlockIdx := i;
- fLastKnownCountBefore := CountBefore;
- Result := Pointer( PDWORD( Integer( BlockStart ) + (Idx - CountBefore) * Sizeof( Pointer ) )^ );
- Exit;
- end;
- inc( CountBefore, CountCurrent );
- inc( i );
- end;
- end
- else
- {$ENDIF}
- Result := fItems[ Idx ];
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TList.IndexOf]
- {$IFDEF ASM_TLIST}
- {$ELSE ASM_VERSION} //Pascal
- function TList.IndexOf( Value: Pointer ): Integer;
- var I: Integer;
- {$IFDEF TLIST_FAST}
- BlockStart: PDWORD;
- j: Integer;
- CountBefore, CountCurrent: Integer;
- {$ENDIF}
- begin
- {$IFDEF DEBUG}
- TRY
- {$ENDIF}
- Result := -1;
- {$IFDEF TLIST_FAST}
- if fUseBlocks and Assigned( fBlockList ) then
- begin
- CountBefore := 0;
- for I := 0 to fBlockList.fCount div 2 - 1 do
- begin
- BlockStart := fBlockList.fItems[ I * 2 ];
- CountCurrent := Integer( fBlockList.fItems[ I * 2 + 1 ] );
- for j := 0 to CountCurrent-1 do
- begin
- if BlockStart^ = DWORD( Value ) then
- begin
- Result := CountBefore + j;
- Exit;
- end;
- inc( BlockStart );
- end;
- inc( CountBefore, CountCurrent );
- end;
- end
- else
- {$ENDIF}
- begin
- for I := 0 to fCount - 1 do
- begin
- if fItems[ I ] = Value then
- begin
- Result := I;
- break;
- end;
- end;
- end;
- {$IFDEF DEBUG}
- EXCEPT
- asm
- nop
- end;
- END;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.Insert]
- {$IFDEF ASM_TLIST}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.Insert(Idx: Integer; Value: Pointer);
- {$IFDEF TLIST_FAST}
- var i: Integer;
- CountBefore, CountCurrent: Integer;
- BlockStart, NewBlock: Pointer;
- {$ENDIF}
- begin
- Assert( (Idx >= 0) and (Idx <= FCount+1), 'List index out of bounds' );
- {$IFDEF TLIST_FAST}
- if fUseBlocks and (Assigned( fBlockList ) or (fCount >= 256)) then
- begin
- if not Assigned( fBlockList ) then
- begin
- fBlockList := NewList;
- fBlockList.fUseBlocks := FALSE;
- fBlockList.Add( fItems );
- fBlockList.Add( Pointer( fCount ) );
- fItems := nil;
- end;
- if fBlockList.fCount = 0 then
- begin
- GetMem( NewBlock, 256 * Sizeof( Pointer ) );
- fBlockList.Add( NewBlock );
- fBlockList.Add( nil );
- end;
- CountBefore := 0;
- i := 0;
- if (fLastKnownBlockIdx > 0) and
- (Idx >= fLastKnownCountBefore) then
- begin
- i := fLastKnownBlockIdx;
- CountBefore := fLastKnownCountBefore;
- end;
- while TRUE {i < fBlockList.fCount div 2} do
- begin
- CountCurrent := Integer( fBlockList.Items[ i * 2 + 1 ] );
- if (Idx >= CountBefore) and
- ((Idx < CountBefore + CountCurrent) or
- (Idx = CountBefore + CountCurrent) and
- (CountCurrent < 256)) then // insert in block i
- begin
- BlockStart := fBlockList.fItems[ i * 2 ];
- if BlockStart = nil then
- begin
- GetMem( BlockStart, 256 * Sizeof( Pointer ) );
- fBlockList.fItems[ i * 2 ] := BlockStart;
- end;
- Idx := Idx - CountBefore;
- if CountCurrent < 256 then
- begin
- if Idx < CountCurrent then
- Move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
- Pointer( Integer( BlockStart ) + (Idx+1) * Sizeof( Pointer ) )^,
- (CountCurrent - Idx) * Sizeof( Pointer ) );
- PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
- DWORD( Value );
- fBlockList.fItems[ i * 2 + 1 ] := Pointer( CountCurrent + 1 );
- end
- else // new block is created since current block is full 256 items
- begin
- GetMem( NewBlock, 256 * Sizeof( Pointer ) );
- fBlockList.Insert( (i+1)*2, Pointer( 256-Idx ) );
- fBlockList.Insert( (i+1)*2, NewBlock );
- move( Pointer( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^,
- NewBlock^, (256 - Idx) * Sizeof( Pointer ) );
- PDWORD( Integer( BlockStart ) + Idx * Sizeof( Pointer ) )^ :=
- DWORD( Value );
- fBlockList.fItems[ i * 2 + 1 ] := Pointer( Idx + 1 );
- end;
- fLastKnownBlockIdx := i;
- fLastKnownCountBefore := CountBefore;
- inc( fCount );
- Exit;
- end;
- inc( CountBefore, CountCurrent );
- inc( i );
- if i >= fBlockList.fCount div 2 then
- begin
- fBlockList.Add( nil );
- fBlockList.Add( nil );
- end;
- end;
- end
- else
- {$ENDIF}
- begin
- Add( nil );
- if fCount > Idx then
- Move( FItems[ Idx ], FItems[ Idx + 1 ], (fCount - Idx - 1) * Sizeof( Pointer ) );
- FItems[ Idx ] := Value;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.MoveItem]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.MoveItem(OldIdx, NewIdx: Integer);
- var Item: Pointer;
- begin
- if OldIdx = NewIdx then Exit;
- if NewIdx >= Count then Exit;
- Item := Items[ OldIdx ];
- Delete( OldIdx );
- Insert( NewIdx, Item );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TList.Last]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TList.Last: Pointer;
- begin
- if Count = 0 then
- Result := nil
- else
- Result := Items[ Count-1 ];
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.Swap]
- {$IFDEF ASM_TLIST}
- {$ELSE ASM_VERSION} //Pascal
- procedure TList.Swap(Idx1, Idx2: Integer);
- var Tmp: DWORD;
- AItem1, AItem2: PDWORD;
- begin
- {$IFDEF TLIST_FAST}
- AItem1 := ItemAddress( Idx1 );
- AItem2 := ItemAddress( Idx2 );
- {$ELSE}
- AItem1 := Pointer( cardinal( fItems ) + cardinal(Idx1) * Sizeof( Pointer ) );
- AItem2 := Pointer( cardinal( fItems ) + cardinal(Idx2) * Sizeof( Pointer ) );
- {$ENDIF}
- Tmp := AItem1^;
- AItem1^ := AItem2^;
- AItem2^ := Tmp;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TList.SetCount]
- procedure TList.SetCount(const Value: Integer);
- begin
- if Value >= Count then exit;
- fCount := Value;
- end;
-
- //[procedure TList.Assign]
- procedure TList.Assign(SrcList: PList);
- {$IFDEF TLIST_FAST}
- var i, CountCurrent: Integer;
- SrcBlock, DstBlock: Pointer;
- {$ENDIF}
- begin
- Clear;
- if SrcList.fCount > 0 then
- begin
- {$IFDEF TLIST_FAST}
- if SrcList.fUseBlocks and Assigned( SrcList.fBlockList ) then
- begin
- fBlockList := NewList;
- fBlockList.Assign( SrcList.fBlockList );
- for i := 0 to fBlockList.Count div 2 - 1 do
- begin
- SrcBlock := SrcList.fBlockList.fItems[ i*2 ];
- CountCurrent := Integer( fBlockList.fItems[ i*2+1 ] );
- GetMem( DstBlock, 256 * Sizeof( Pointer ) );
- fBlockList.fItems[ i*2 ] := DstBlock;
- move( SrcBlock^, DstBlock^, CountCurrent );
- end;
- end
- else
- {$ENDIF}
- begin
- Capacity := SrcList.fCount;
- Move( SrcList.FItems[ 0 ], FItems[ 0 ], Sizeof( Pointer ) * SrcList.fCount );
- end;
- end;
- fCount := SrcList.fCount;
- end;
-
- {$IFDEF WIN_GDI}
-
- { -- Window procedure -- }
-
- function CallCtlWndProc_1( Ctl: PControl; var Msg: TMsg ): Integer;
- begin
- Result := Ctl.WndProc( Msg );
- end;
- (*
- function WndFunc_asm( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
- : Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- const size_TMsg = sizeof( TMsg );
- asm
- ADD ESP, -size_TMsg
- MOV EDX, ESP
-
- PUSH ESI
- PUSH EDI
-
- MOV EDI, EDX
- LEA ESI, [W]
-
- MOVSD
- MOVSD
- MOVSD
- MOVSD
-
- MOV EDI, EDX
- MOV EAX, [EDI]
- TEST EAX, EAX
- JZ @@self_is_nil
-
- MOV ECX, [CreatingWindow]
- JECXZ @@get_self_prop
-
- MOV [ECX].TControl.fHandle, EAX
-
- PUSH ECX
- PUSH ECX
- {$IFDEF USE_PROP}
- PUSH Offset[ID_SELF]
- PUSH EAX
- CALL SetProp
- {$ELSE}
- PUSH GWL_USERDATA
- PUSH EAX
- CALL SetWindowLong
- {$ENDIF}
-
- XOR EAX, EAX
- MOV [CreatingWindow], EAX
- POP EAX // EAX = self_
- JMP @@self_got
-
- @@get_self_prop:
- {$IFDEF USE_PROP}
- PUSH Offset[ID_SELF]
- PUSH EAX
- CALL GetProp
- {$ELSE}
- PUSH GWL_USERDATA
- PUSH EAX
- CALL GetWindowLong
- {$ENDIF}
- TEST EAX, EAX
- JNZ @@self_got
-
- @@self_is_nil:
- OR EAX, [ Applet ]
- JNZ @@self_got
-
- POP EDI
- POP ESI
- MOV ESP, EBP
- POP EBP
- JMP DefWindowProc
-
- @@self_got:
- MOV ESI, EAX
- INC [ESI].TControl.fNestedMsgHandling
- MOV EDX, EDI
- CALL CallCtlWndProc_1
- DEC [ESI].TControl.fNestedMsgHandling
- JG @@1
- CMP [ESI].TControl.fBeginDestroying, 0
- JZ @@1
- CMP [ESI].TObj.fRefCount, 0
- JNZ @@1
- CMP ESI, [Applet]
- JZ @@1
- XCHG EAX, ESI
- CALL TObj.RefDec
- XCHG ESI, EAX
- @@1:
-
- POP EDI
- POP ESI
-
- MOV ESP, EBP
- end;
- *)
- {$UNDEF ASM_LOCAL}
- {$IFDEF ASM_noVERSION}
- {$IFNDEF _D2orD3}
- {$DEFINE ASM_LOCAL}
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF ASM_LOCAL} //!!//!!
- //[FUNCTION CallCtlWndProc]
- function CallCtlWndProc( Ctl: PControl; var Msg: TMsg ): Integer;
- begin
- Result := Ctl.WndProc( Msg );
- end;
- //[END CallCtlWndProc]
-
- //[function WndFunc]
- function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
- : Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- const size_TMsg = sizeof( TMsg );
- asm
- ADD ESP, -size_TMsg
- MOV EDX, ESP
-
- PUSH ESI
- PUSH EDI
-
- MOV EDI, EDX
- LEA ESI, [W]
-
- MOVSD
- MOVSD
- MOVSD
- MOVSD
-
- MOV EDI, EDX
- MOV EAX, [EDI]
- TEST EAX, EAX
- JZ @@self_is_nil
-
- MOV ECX, [CreatingWindow]
- JECXZ @@get_self_prop
-
- MOV [ECX].TControl.fHandle, EAX
-
- PUSH ECX
- PUSH ECX
- {$IFDEF USE_PROP}
- PUSH Offset[ID_SELF]
- PUSH EAX
- CALL SetProp
- {$ELSE}
- PUSH GWL_USERDATA
- PUSH EAX
- CALL SetWindowLong
- {$ENDIF}
-
- XOR EAX, EAX
- MOV [CreatingWindow], EAX
- POP EAX // EAX = self_
- JMP @@self_got
-
- @@get_self_prop:
- {$IFDEF USE_PROP}
- PUSH Offset[ID_SELF]
- PUSH EAX
- CALL GetProp
- {$ELSE}
- PUSH GWL_USERDATA
- PUSH EAX
- CALL GetWindowLong
- {$ENDIF}
- TEST EAX, EAX
- JNZ @@self_got
-
- @@self_is_nil:
- OR EAX, [ Applet ]
- JNZ @@self_got
-
- POP EDI
- POP ESI
- MOV ESP, EBP
- POP EBP
- JMP DefWindowProc
-
- @@self_got:
- MOV ESI, EAX
- INC [ESI].TControl.fNestedMsgHandling
- MOV EDX, EDI
- CALL CallCtlWndProc
- DEC [ESI].TControl.fNestedMsgHandling
- JA @@1
- CMP [ESI].TControl.fBeginDestroying, 0
- JZ @@1
- CMP [ESI].TObj.fRefCount, 0
- JNZ @@1
- CMP ESI, [Applet]
- JZ @@1
- XCHG EAX, ESI
- CALL TObj.Free
- XCHG ESI, EAX
- @@1:
-
- POP EDI
- POP ESI
-
- MOV ESP, EBP
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndFunc( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
- : Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var M: TMsg;
- self_: PControl;
- begin
- {if (Msg >= $BD33) and (Msg <= $BD33) then
- begin
- Result := WndFunc_asm( W, Msg, wParam, lParam );
- Exit;
- end;}
-
- {$IFDEF INPACKAGE}
- Log( '->WndFunc ' + Int2Hex( Msg, 4 ) + ' (' + Int2Str( Msg ) + ')' );
- TRY
- {$ENDIF INPACKAGE}
-
- M.hwnd := W;
- M.message := Msg;
- M.wParam := wParam;
- M.lParam := lParam;
-
- {$IFDEF DEBUG_ENDSESSION}
- if EndSession_Initiated then
- begin
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
- ' WParam: ' + Int2Str( wParam ) + '($' + Int2Hex( wParam, 8 ) + ')' +
- ' LParam: ' + Int2Str( lParam ) + '($' + Int2Hex( lParam, 8 ) + ')' );
- end;
- {$ENDIF}
-
- self_ := nil;
- if W <> 0 then
- begin
- if CreatingWindow <> nil then
- begin
- {$IFDEF INPACKAGE}
- Log( '//// CreatingWindow <> nil' );
- {$ENDIF INPACKAGE}
- {$IFDEF DEBUG_CREATEWINDOW}
- LogFileOutput( GetStartDir + 'Session.log',
- 'WndFunc: Creating window = ' + Int2Hex( Integer( CreatingWindow ), 4 ) +
- ' hwnd=' + Int2Str( M.hwnd ) +
- ' message=' + Int2Hex( M.message, 4 ) +
- ' wParam=' + Int2Str( M.wParam ) + '=$' + Int2Hex( M.wParam, 4 ) +
- ' lParam=' + Int2Str( M.lParam ) + '=$' + Int2Hex( M.lParam, 4 )
- );
- {$ENDIF DEBUG_CREATEWINDOW}
- self_ := CreatingWindow;
- CreatingWindow.fHandle := W;
- {$IFDEF USE_PROP}
- {$IFDEF INPACKAGE}
- Log( '//// SetProp' );
- {$ENDIF INPACKAGE}
- SetProp( W, ID_SELF, THandle( CreatingWindow ) );
- {$ELSE}
- SetWindowLong( W, GWL_USERDATA, Integer( CreatingWindow ) );
- {$ENDIF}
- CreatingWindow := nil;
- end
- else
- {$IFDEF USE_PROP}
- self_ := Pointer( GetProp( W, ID_SELF ) );
- {$ELSE}
- self_ := Pointer( GetWindowLong( W, GWL_USERDATA ) );
- {$ENDIF}
- end;
-
- if self_ <> nil then
- begin
- {$IFDEF INPACKAGE}
- Log( '//// self_ <> nil, calling self_.WndProc' );
- {$ENDIF INPACKAGE}
- inc( self_.fNestedMsgHandling );
- Result := self_.WndProc( M );
- dec( self_.fNestedMsgHandling );
- if (self_.RefCount = 0) and (self_.fNestedMsgHandling <= 0) and
- self_.fBeginDestroying and (self_ <> Applet) then
- self_.Free;
- end
- else
- if Assigned( Applet ) then
- Result := Applet.WndProc( M )
- else
- Result := DefWindowProc( W, Msg, wParam, lParam );
- {$IFDEF DEBUG_ENDSESSION}
- if EndSession_Initiated then
- begin
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'HWND:' + Int2Str( W ) + ' MSG:$' + Int2Hex( Msg, 4 ) +
- ' Result: ' + Int2Str( Result ) + '($' + Int2Hex( Result, 8 ) + ')' );
- end;
- {$ENDIF}
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-WndFunc' );
- END;
- {$ENDIF INPACKAGE}
- end;
- //[END WndFunc]
- {$ENDIF ASM_VERSION}
-
- {$IFDEF USE_OnIdle}
- var
- IdleHandlers: PList;
- ProcessIdle: procedure ( Sender: PObj ) = DummyObjProc;
-
- //[procedure ProcessIdleProc]
- procedure ProcessIdleProc( Sender: PObj );
- var
- i: integer;
- m: TMethod;
- begin
- if AppletTerminated then exit; // YS +
- i := 0;
- with IdleHandlers{-}^{+} do
- while i < Count do begin
- m.Code:=Items[i];
- Inc(i);
- m.Data:=Items[i];
- Inc(i);
- TOnEvent(m)(Sender);
- end;
- end;
-
- //[function FindIdleHandler]
- function FindIdleHandler( const OnIdle: TOnEvent ): integer;
- var
- i: integer;
- begin
- i := 0;
- if not AppletTerminated then //+ {Maxim Pushkar}
- with TMethod(OnIdle), IdleHandlers{-}^{+} do
- while i < Count do begin
- if (Items[i] = Code) and (Items[i + 1] = Data) then
- begin
- Result := i;
- exit;
- end;
- Inc(i, 2);
- end;
- Result := -1;
- end;
- //[END FindIdleHandler]
-
- //[procedure RegisterIdleHandler]
- procedure RegisterIdleHandler( const OnIdle: TOnEvent );
- begin
- if AppletTerminated then exit;
- if IdleHandlers = nil then begin
- IdleHandlers := NewList;
- if Applet <> nil then
- Applet.Add2AutoFree(IdleHandlers);
- end;
- with TMethod(OnIdle) do
- begin
- IdleHandlers.Add(Code);
- IdleHandlers.Add(Data);
- end;
- ProcessIdle := @ProcessIdleProc;
- end;
-
- //[procedure UnRegisterIdleHandler]
- procedure UnRegisterIdleHandler( const OnIdle: TOnEvent );
- var
- i: integer;
- begin
- i := FindIdleHandler(OnIdle);
- if i <> -1 then
- with IdleHandlers{-}^{+} do
- begin
- Delete(i);
- Delete(i);
- end;
- end;
- {$ENDIF USE_OnIdle}
-
- {$IFDEF GDI}
- //[procedure TerminateExecution]
- {$IFDEF ASM_noVERSION}
- procedure TerminateExecution( var AppletWnd: PControl );
- asm
- PUSH EBX
- PUSH ESI
- MOV BX, $0100
- XCHG BX, word ptr [AppletRunning]
- XOR ECX, ECX
- XCHG ECX, [Applet]
- JECXZ @@exit
- PUSH EAX
-
- XCHG EAX, ECX
- MOV ESI, EAX
- CALL TObj.RefInc
-
- TEST BH, BH
- JE @@closed
-
- MOV EAX, ESI
- CALL TControl.ProcessMessages
- PUSH 0
- PUSH 0
- PUSH WM_CLOSE
- PUSH ESI
- CALL TControl.Perform
- @@closed:
- POP EAX
- XOR ECX, ECX
- MOV dword ptr [EAX], ECX
- MOV EAX, ESI
- CALL TObj.Free
- XCHG EAX, ESI
- CALL TObj.RefDec
- @@exit:
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION}
- procedure TerminateExecution( var AppletWnd: PControl );
- var App: PControl;
- Appalreadyterminated: Boolean;
- begin
- Appalreadyterminated := AppletTerminated;
- AppletTerminated := TRUE;
- AppletRunning := FALSE;
- App := Applet;
- Applet := nil;
- if (App <> nil) {and (App.RefCount >= 0)} then
- begin
- App.RefInc;
- if not Appalreadyterminated then
- begin
- App.ProcessMessages;
- App.Perform( WM_CLOSE, 0, 0 );
- end;
- AppletWnd := nil;
- App.Free;
- App.RefDec;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[PROCEDURE CallTControlCreateWindow]
- procedure CallTControlCreateWindow( Ctl: PControl );
- begin
- {$IFDEF SAFE_CODE}
- TRY
- if Ctl = nil then Exit;
- Ctl.CreateWindow;
- EXCEPT
- asm
- nop
- end;
- END;
- {$ELSE}
- Ctl.CreateWindow;
- {$ENDIF}
- end;
- //[END CallTControlCreateWindow]
- {$ENDIF GDI}
- {$ENDIF WIN_GDI}
-
- {$IFDEF GDI}
- //[PROCEDURE Run]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure Run( var AppletWnd: PControl );
- {$IFDEF PSEUDO_THREADS}
- var n: Integer;
- i: Integer;
- T: PThread;
- u: DWORD;
- M: TMsg;
- {$ENDIF}
- begin
- AppletRunning := True;
- Applet := AppletWnd;
- AppletWnd.CreateWindow; //virtual!!!
- while not AppletTerminated do
- begin
- {$ifdef wince}
- AppletWnd.WaitAndProcessMessages;
- {$else}
- {$IFDEF PSEUDO_THREADS}
- if Assigned( MainThread ) then
- begin
- while not PeekMessage( M, 0, 0, 0, pm_noremove ) do
- begin
- u := GetTickCount;
- n := 0;
- for i := 1 to MainThread.AllThreads.Count-1 do
- begin
- T := MainThread.AllThreads.Items[ i ];
- if not T.Suspended and not T.Terminated and (T.DoNotWakeUntil < u) then
- begin
- inc( n );
- break;
- end;
- end;
- if n = 0 then WaitMessage
- else MainThread.NextThread;
- end;
- end
- else
- WaitMessage;
- {$ELSE}
- WaitMessage;
- {$ENDIF}
- AppletWnd.ProcessMessages;
- {$endif wince}
- {$IFDEF USE_OnIdle}
- ProcessIdle( AppletWnd );
- {$ENDIF}
- end;
- if AppletWnd <> nil then
- TerminateExecution( AppletWnd );
- end;
- //[END Run]
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure Run( var AppletWnd: PControl );
- begin
- AppletRunning := True;
- Applet := AppletWnd;
- AppletWnd.VisualizyWindow; // for GTK, show all windows having Visible = TRUE, recursively
- gtk_main( );
- if AppletWnd <> nil then
- //TerminateExecution( AppletWnd );
- Free_And_Nil( AppletWnd );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- {$IFDEF GDI}
- //[procedure AppletMinimize]
- procedure AppletMinimize;
- begin
- if Applet = nil then Exit;
- Applet.Perform( WM_SYSCOMMAND, SC_MINIMIZE, 0 );
- end;
-
- //[procedure AppletHide]
- procedure AppletHide;
- begin
- if Applet = nil then Exit;
- AppletMinimize;
- Applet.Hide;
- end;
-
- //[procedure AppletRestore]
- procedure AppletRestore;
- begin
- if Applet = nil then Exit;
- Applet.Show;
- Applet.Perform( WM_SYSCOMMAND, SC_RESTORE, 0 );
- end;
-
- //[function ScreenWidth]
- function ScreenWidth: Integer;
- begin
- Result := GetSystemMetrics( SM_CXSCREEN );
- end;
- //[END ScreenWidth]
-
- //[function ScreenHeight]
- function ScreenHeight: Integer;
- begin
- Result := GetSystemMetrics( SM_CYSCREEN );
- end;
- //[END ScreenHeight]
- {$ENDIF GDI}
-
- //[WndProcXXX FORWARD DECLARATIONS]
- {$IFDEF ASM_VERSION}
- function WndProcAppAsm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- {$ELSE}
- function WndProcAppPas( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- {$ENDIF ASM_VERSION}
- function WndProcForm( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean; forward;
- var fGlobalProcKeybd: function( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean =
- WndProcDummy;
- //[END OF WndProcXXX FORWARD DECLARATIONS]
-
- { -- Graphics support -- }
-
- {$ENDIF WIN_GDI}
- //[function _NewGraphicTool]
- function _NewGraphicTool: PGraphicTool;
- begin
- {-}
- New( Result, Create );
- {+}
- {++}(*Result := PGraphicTool.Create;*){--}
- end;
- //[END _NewGraphicTool]
- {$IFDEF WIN_GDI}
-
- //[FUNCTION SimpleGetCtlBrushHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION PAS_VERSION}
- function SimpleGetCtlBrushHandle( Sender: PControl ): HBrush;
- begin
- if (Sender.fParent <> nil) and (Sender.fColor = Sender.fParent.fColor) then
- Result := SimpleGetCtlBrushHandle( Sender.fParent )
- else
- begin
- {$IFDEF GDI}
- if (Sender.fTmpBrush <> 0) and
- (Color2RGB( Sender.fColor ) <> Sender.fTmpBrushColorRGB) then
- begin
- DeleteObject( Sender.fTmpBrush );
- Sender.fTmpBrush := 0;
- end;
- if Sender.fTmpBrush = 0 then
- begin
- Sender.fTmpBrushColorRGB := Color2RGB( Sender.fColor );
- Sender.fTmpBrush := CreateSolidBrush( Sender.fTmpBrushColorRGB );
- end;
- Result := Sender.fTmpBrush;
- {$ELSE} Result := 0;
- {$ENDIF GDI}
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END SimpleGetCtlBrushHandle]
-
- //[function NormalGetCtlBrushHandle]
- function NormalGetCtlBrushHandle( Sender: PControl ): HBrush;
- begin
- {$IFDEF GDI}
- if (Sender.fParent <> nil) and (Sender.fParent.fColor <> Sender.fColor) then
- Sender.Brush.fParentGDITool := Sender.fParent.Brush;
- Result := Sender.Brush.Handle;
- {$ELSE} Result := 0;
- {$ENDIF GDI}
- end;
- //[END NormalGetCtlBrushHandle]
-
- {++}(*
- //[API CreateFontIndirect]
- function CreateFontIndirect(const p1: TLogFont): HFONT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external gdi32 name 'CreateFontIndirectA';
- *){--}
- //[MakeXXXHandle FORWARD DECLARATIONS]
- function MakeFontHandle( Self_: PGraphicTool ): THandle; forward;
- function MakeBrushHandle( Self_: PGraphicTool ): THandle; forward;
- function MakePenHandle( Self_: PGraphicTool ): THandle; forward;
- function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle; forward;
- //[END OF MakeXXXHandle FORWARD DECLARATIONS]
-
- {$ENDIF WIN_GDI}
- //[FUNCTION NewBrush]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewBrush: PGraphicTool;
- begin
- {$IFDEF GDI}
- Global_GetCtlBrushHandle := NormalGetCtlBrushHandle;
- {$ENDIF GDI}
- Result := _NewGraphicTool;
- with Result {-}^{+} do
- begin
- fNewProc := @ NewBrush;
- fType := gttBrush;
- {$IFDEF GDI}
- fMakeHandleProc := @ MakeBrushHandle;
- {$ENDIF GDI}
- Result.fData.Color := {$ifdef wince}clWindow{$else}clBtnFace{$endif};
- Result.fData.Brush.Style := bsSolid;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewBrush]
-
- //[FUNCTION NewPen]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewPen: PGraphicTool;
- begin
- Result := _NewGraphicTool;
- with Result{-}^{+} do
- begin
- fNewProc := @ NewPen;
- fType := gttPen;
- {$IFDEF GDI}
- fMakeHandleProc := @ MakePenHandle;
- {$ENDIF GDI}
- fData.Pen.Mode := pmCopy;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewPen]
-
- var ApplyFont2Wnd_Proc: procedure( _Self: PControl ) = nil;
- procedure DoApplyFont2Wnd( _Self: PControl ); forward;
-
- const size_FontData = sizeof( Integer {fFontHeight} ) + sizeof( Integer {fFontWidth} ) +
- sizeof( TFontPitch ) + sizeof( TFontStyle ) +
- sizeof( Integer {fFontOrientation} ) +
- sizeof( Integer {fFontWeight} ) + sizeof( TFontCharset ) +
- sizeof( TFontQuality );
-
- //[FUNCTION NewFont]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewFont: PGraphicTool;
- begin
- ApplyFont2Wnd_Proc := @ DoApplyFont2Wnd;
- Result := _NewGraphicTool;
- with Result {-}^{+} do
- begin
- fNewProc := @ NewFont;
- fType := gttFont;
- {$IFDEF GDI}
- fMakeHandleProc := @ MakeFontHandle;
- fData.Color := DefFontColor;
- Move( DefFont, fData.Font, Sizeof( TGDIFont ) );
- {$ENDIF GDI}
- {$IFDEF GTK}
- fData.Font.Weight := 400;
- {$ENDIF GTK}
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewFont]
-
- //[function Color2RGB]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function Color2RGB( Color: TColor ): TColor;
- begin
- if Color < 0 then
- Result := GetSysColor(Color and $7FFFFFFF) else
- Result := Color;
- end;
- {$ENDIF ASM_VERSION}
- //[END Color2RGB]
-
- function RGB2BGR( Color: TColor ): TColor;
- begin
- Result := ((Color shr 16) or (Color shl 16) or Color and $00FF00)
- and $FFFFFF;
- end;
-
- //[function ColorsMix]
- {$IFDEF ASM_VERSION}
- function ColorsMix( Color1, Color2: TColor ): TColor;
- asm
- PUSH EDX
- CALL Color2Rgb
- XCHG EAX, [ESP]
- CALL Color2Rgb
- POP EDX
- AND EAX, 0FEFEFEh
- AND EDX, 0FEFEFEh
- SHR EAX, 1
- SHR EDX, 1
- ADD EAX, EDX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function ColorsMix( Color1, Color2: TColor ): TColor;
- begin
- Result := ((Color2RGB( Color1 ) and $FEFEFE) shr 1) +
- ((Color2RGB( Color2 ) and $FEFEFE) shr 1);
- end;
- {$ENDIF ASM_VERSION}
- //[END ColorsMix]
-
- {$IFDEF WIN_GDI}
- //[FUNCTION Color2RGBQuad]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Color2RGBQuad( Color: TColor ): TRGBQuad;
- var C: Integer;
- begin
- C := Color2RGB( Color );
- C := ((C shr 16) and $FF)
- or ((C shl 16) and $FF0000)
- or (C and $FF00);
- Result := TRGBQuad( C );
- end;
- {$ENDIF ASM_VERSION}
- //[END Color2RGBQuad]
-
- //[FUNCTION Color2Color16]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function Color2Color16( Color: TColor ): WORD;
- begin
- Color := Color2RGB( Color );
- Result := (Color shr 19) and $1F or
- (Color shr 5) and $7E0 or
- (Color shl 8) and $F800;
- end;
- {$ENDIF ASM_VERSION}
- //[END Color2Color16]
-
- //[FUNCTION Color2Color15]
- function Color2Color15( Color: TColor ): WORD;
- begin
- Color := Color2RGB( Color );
- Result := (Color shr 19) and $1F or
- (Color shr 6) and $3E0 or
- (Color shl 7) and $7C00;
- end;
- //[END Color2Color15]
-
- {$ENDIF WIN_GDI}
- { TGraphicTool }
-
- //[function TGraphicTool.Assign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function TGraphicTool.Assign(Value: PGraphicTool): PGraphicTool;
- var _Self: PGraphicTool;
- begin
- Result := nil;
- if Value = nil then
- begin
- {$IFDEF OLD_REFCOUNT}
- if @Self <> nil then
- DoDestroy;
- {$ELSE}
- Free;
- {$ENDIF}
- Exit;
- end;
- _Self := @Self;
- if _Self = nil then
- _Self := Value.fNewProc();
- Result := _Self;
- if _Self = Value then Exit; // to avoid infinite loop when assigning to itself
- {$IFDEF GDI}
- if _Self.fHandle <> 0 then
- if Value.fHandle = _Self.fHandle then Exit;
- {$ENDIF GDI}
- _Self.Changed; // to destroy handle if allocated and release it from the canvas (if any uses it)
- Assert( Value.fType = _Self.fType, 'Attempt to assign to different GDI tool type' );
- Move( Value.fData, _Self.fData, Sizeof( fData ) );
- _Self.Changed; // to inform owner control, that its tool (font, brush) changed
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- //[procedure TGraphicTool.AssignHandle]
- procedure TGraphicTool.AssignHandle(NewHandle: Integer);
- begin
- if fHandle <> 0 then //
- DeleteObject( fHandle ); //
- fHandle := NewHandle;
- GetObject( fHandle, Sizeof( TGDIFont ), @ fData.Font );
- Changed;
- end;
-
- {$ENDIF WIN_GDI}
- //[procedure TGraphicTool.Changed]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TGraphicTool.Changed;
- {$IFDEF GDI} var H: THandle; {$ENDIF GDI}
- begin
- {$IFDEF GDI}
- H := 0;
- if fHandle <> 0 then
- begin
- H := fHandle;
- fHandle := 0;
- end;
- ////////////////////////////////
- if Assigned( fOnChange ) then
- fOnChange( @Self );
- ////////////////////////////////
- if H <> 0 then
- begin
- DeleteObject( H );
- {$IFDEF DEBUG_GDIOBJECTS}
- case fType of
- gttBrush: Dec( BrushCount );
- gttFont: Dec( FontCount );
- gttPen: Dec( PenCount );
- end;
- {$ENDIF}
- end;
- {$ENDIF GDI}
- {$IFDEF GTK}
- if Assigned( fPangoFontDesc ) then
- begin
- pango_font_description_free( fPangoFontDesc );
- fPangoFontDesc := nil;
- end;
- if Assigned( fOnChange ) then
- fOnChange( @Self );
- {$ENDIF GTK}
- end;
- {$ENDIF ASM_VERSION}
-
- //[destructor TGraphicTool.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TGraphicTool.Destroy;
- begin
- {$IFDEF GDI}
- case fType of
- gttBrush: if fData.Brush.Bitmap <> 0 then
- DeleteObject( fData.Brush.Bitmap );
- gttPen: if fData.Pen.BrushBitmap <> 0 then
- DeleteObject( fData.Pen.BrushBitmap )
- end;
- if fHandle <> 0 then
- begin
- DeleteObject( fHandle );
- {$IFDEF DEBUG_GDIOBJECTS}
- case fType of
- gttPen: Dec( PenCount );
- gttBrush: Dec( BrushCount );
- gttFont: Dec( FontCount );
- end;
- {$ENDIF}
- //fHandle := 0; Why to do this? It is now destroying!
- end;
- {$ENDIF GDI}
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[function TGraphicTool.HandleAllocated]
- function TGraphicTool.HandleAllocated: Boolean;
- begin
- Result := fHandle <> 0;
- end;
-
- //[function TGraphicTool.ReleaseHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION PAS_VERSION}
- function TGraphicTool.ReleaseHandle: Integer;
- begin
- Changed;
- Result := fHandle;
- fHandle := 0;
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[procedure TGraphicTool.SetInt]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TGraphicTool.SetInt( const Index: Integer; Value: Integer );
- var Where: PInteger;
- begin
- Where := Pointer( cardinal( @ fData ) + cardinal(Index) );
- if {$ifdef wince}unaligned{$endif}(Where^) = Value then Exit;
- {$ifdef wince}unaligned({$endif}Where^{$ifdef wince}){$endif} := Value;
- Changed;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TGraphicTool.GetInt]
- function TGraphicTool.GetInt(const Index: Integer): Integer;
- var Where: PInteger;
- begin
- Where := Pointer( cardinal( @ fData ) + cardinal(Index) );
- Result := Where^;
- end;
- {$IFDEF WIN_GDI}
-
- {$ENDIF WIN_GDI}
- //[procedure TGraphicTool.SetColor]
- procedure TGraphicTool.SetColor( Value: TColor );
- begin
- SetInt( go_Color, Value );
- fColorRGB := Color2RGB( Value );
- end;
- {$IFDEF WIN_GDI}
-
- //[function TGraphicTool.IsFontTrueType]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- {$ifdef wince}
- function TGraphicTool.IsFontTrueType: Boolean;
- begin
- Result:=True;
- end;
- {$else}
- function TGraphicTool.IsFontTrueType: Boolean;
- var OldFont: HFont;
- DC: HDC;
- begin
- Result := False;
- if GetHandle = 0 then Exit;
- DC := GetDC( 0 );
- OldFont := SelectObject( DC, fHandle );
- if GetFontData( DC, 0, 0, nil, 0 ) <> GDI_ERROR then
- Result := True;
- SelectObject( DC, OldFont );
- ReleaseDC( 0, DC );
- end;
- {$endif wince}
- {$ENDIF ASM_VERSION}
-
- //[function TGraphicTool.GetBrushBitmap]
- function TGraphicTool.GetBrushBitmap: HBitmap;
- begin
- Result := fData.Brush.Bitmap; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetBrushBitmap]
- procedure TGraphicTool.SetBrushBitmap(const Value: HBitmap);
- begin
- if fData.Brush.Bitmap = Value then Exit;
- if fData.Brush.Bitmap <> 0 then
- begin
- Changed; // !!!
- DeleteObject( fData.Brush.Bitmap );
- end;
- fData.Brush.Bitmap := Value;
- Changed;
- end;
-
- //[function TGraphicTool.GetBrushStyle]
- function TGraphicTool.GetBrushStyle: TBrushStyle;
- begin
- Result := fData.Brush.Style; // for BCB only
- end;
-
- {$ENDIF WIN_GDI}
- //[procedure TGraphicTool.SetBrushStyle]
- procedure TGraphicTool.SetBrushStyle(const Value: TBrushStyle);
- begin
- if fData.Brush.Style = Value then Exit;
- fData.Brush.Style := Value;
- Changed;
- end;
- {$IFDEF WIN_GDI}
-
- //[function TGraphicTool.GetFontCharset]
- function TGraphicTool.GetFontCharset: TFontCharset;
- begin
- Result := fData.Font.CharSet; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetFontCharset]
- procedure TGraphicTool.SetFontCharset(const Value: TFontCharset);
- begin
- if fData.Font.Charset = Value then Exit;
- fData.Font.Charset := Value;
- Changed;
- end;
-
- //[function TGraphicTool.GetFontQuality]
- function TGraphicTool.GetFontQuality: TFontQuality;
- begin
- Result := fData.Font.Quality; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetFontQuality]
- procedure TGraphicTool.SetFontQuality(const Value: TFontQuality);
- begin
- if fData.Font.Quality = Value then Exit;
- fData.Font.Quality := Value;
- Changed;
- end;
- {$ENDIF WIN_GDI}
-
- //[function TGraphicTool.GetFontName]
- function TGraphicTool.GetFontName: KOLString;
- begin
- Result := fData.Font.Name;
- {$IFDEF GTK}
- if Result = '' then
- Result := 'Sans Serif';
- {$ENDIF GTK}
- end;
-
- //[procedure TGraphicTool.SetFontName]
- procedure TGraphicTool.SetFontName(const Value: KOLString);
- begin
- if fData.Font.Name = Value then Exit;
- FillChar( fData.Font.Name[ 0 ], LF_FACESIZE, #0 );
- {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
- ( fData.Font.Name, PKOLChar( Value ), LF_FACESIZE );
- Changed;
- end;
-
- {$IFDEF WIN_GDI}
- //[procedure TextAreaEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TextAreaEx( Sender: PCanvas; var Sz : TSize; var Pt : TPoint );
- var Orient : Integer;
- Pts : array[ 1..4 ] of TPoint;
- MinX, MinY, I : Integer;
- A : Double;
- begin
- if not Sender.Font.IsFontTrueType then Exit;
- Orient := Sender.Font.FontOrientation;
- Pt.x := 0; Pt.y := 0;
- if Orient = 0 then
- Exit;
- A := Orient / 1800.0 * PI;
- Pts[ 1 ] := Pt;
- Pts[ 2 ].x := Round( Sz.cx * cos( A ) );
- Pts[ 2 ].y := - Round( Sz.cx * sin( A ) );
- Pts[ 4 ].x := - Round( Sz.cy * cos( A + PI / 2 ) );
- Pts[ 4 ].y := Round( Sz.cy * sin( A + PI / 2 ) );
- Pts[ 3 ].x := Pts[ 2 ].x + Pts[ 4 ].x;
- Pts[ 3 ].y := Pts[ 2 ].y + Pts[ 4 ].y;
- MinX := 0; MinY := 0;
- for I := 2 to 4 do
- begin
- if Pts[ I ].x < MinX then
- MinX := Pts[ I ].x;
- if Pts[ I ].y < MinY then
- MinY := Pts[ I ].y;
- end;
- Sz.cx := 0;
- Sz.cy := 0;
- for I := 1 to 4 do
- begin
- Pts[ I ].x := Pts[ I ].x - MinX;
- Pts[ I ].y := Pts[ I ].y - MinY;
- if Pts[ I ].x > Sz.cx then
- Sz.cx := Pts[ I ].x;
- if Pts[ I ].y > Sz.cy then
- Sz.cy := Pts[ I ].y;
- end;
- Pt := Pts[ 1 ];
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TGraphicTool.GetFontOrientation]
- function TGraphicTool.GetFontOrientation: Integer;
- begin
- Result := fData.Font.Orientation; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetFontOrientation]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TGraphicTool.SetFontOrientation(Value: Integer);
- begin
- GlobalGraphics_UseFontOrient := True;
- GlobalCanvas_OnTextArea := TextAreaEx;
- Value := Value mod 3600; // -3599..+3599
- SetInt( go_FontOrientation, Value );
- SetInt( go_FontEscapement, Value );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TGraphicTool.GetFontPitch]
- function TGraphicTool.GetFontPitch: TFontPitch;
- begin
- Result := fData.Font.Pitch; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetFontPitch]
- procedure TGraphicTool.SetFontPitch(const Value: TFontPitch);
- begin
- if fData.Font.Pitch = Value then Exit;
- fData.Font.Pitch := Value;
- Changed;
- end;
- {$ENDIF WIN_GDI}
-
- //[function TGraphicTool.GetFontStyle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TGraphicTool.GetFontStyle: TFontStyle;
- type PFontStyle = ^TFontStyle;
- begin
- Result := [ ];
- if fData.Font.Weight >= 700 then Result := [ fsBold ];
- if fData.Font.Italic then Result := Result + [ fsItalic ];
- if fData.Font.Underline then Result := Result + [ fsUnderline ];
- if fData.Font.StrikeOut then Result := Result + [ fsStrikeOut ];
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TGraphicTool.SetFontStyle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TGraphicTool.SetFontStyle(const Value: TFontStyle);
- begin
- if FontStyle = Value then Exit;
- if fsBold in Value then
- begin
- if fData.Font.Weight < 700 then
- fData.Font.Weight := 700;
- end
- else
- begin
- if fData.Font.Weight >= 700 then
- fData.Font.Weight := 0;
- end;
- fData.Font.Italic := fsItalic in Value;
- fData.Font.Underline := fsUnderline in Value;
- fData.Font.StrikeOut := fsStrikeOut in Value;
- Changed;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[function TGraphicTool.GetPenMode]
- function TGraphicTool.GetPenMode: TPenMode;
- begin
- Result := fData.Pen.Mode; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetPenMode]
- procedure TGraphicTool.SetPenMode(const Value: TPenMode);
- begin
- if fData.Pen.Mode = Value then Exit;
- fData.Pen.Mode := Value;
- Changed;
- end;
-
- //[function TGraphicTool.GetPenStyle]
- function TGraphicTool.GetPenStyle: TPenStyle;
- begin
- Result := fData.Pen.Style; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetPenStyle]
- procedure TGraphicTool.SetPenStyle(const Value: TPenStyle);
- begin
- if fData.Pen.Style = Value then Exit;
- fData.Pen.Style := Value;
- Changed;
- end;
-
- //[function TGraphicTool.GetHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TGraphicTool.GetHandle: THandle;
- begin
- Result := fHandle;
- if Result <> 0 then
- begin
- if Color2RGB( fData.Color ) <> fColorRGB then
- begin
- DeleteObject( ReleaseHandle );
- Result := 0;
- end;
- end;
- if Result = 0 then
- begin
- if Assigned( fParentGDITool ) then
- begin
- if CompareMem( @ fData, @ fParentGDITool.fData, Sizeof( fData ) ) then
- begin
- Result := fParentGDITool.Handle;
- Exit;
- end;
- end;
- fColorRGB := Color2RGB( fData.Color );
- fMakeHandleProc( @Self );
- Result := fHandle;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION MakeBrushHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakeBrushHandle( Self_: PGraphicTool ): THandle;
- {$ifndef wince}
- var
- LogBrush: TLogBrush;
- {$endif wince}
- begin
- if Self_.fHandle = 0 then
- begin
- {$ifdef wince}
- Self_.fHandle := CreateSolidBrush(Color2RGB( Self_.fData.Color ));
- {$else}
- LogBrush.lbColor := Color2RGB( Self_.fData.Color );
- if Self_.fData.Brush.Bitmap <> 0 then
- begin
- LogBrush.lbStyle := BS_PATTERN;
- LogBrush.lbHatch := Self_.fData.Brush.Bitmap;
- end
- else
- begin
- LogBrush.lbHatch := 0;
- case Self_.fData.Brush.Style of
- bsSolid: LogBrush.lbStyle := BS_SOLID;
- bsClear: LogBrush.lbStyle := BS_NULL;
- else
- LogBrush.lbStyle := BS_HATCHED;
- LogBrush.lbHatch := Ord( Self_.fData.Brush.Style ) - Ord( bsHorizontal );
- LogBrush.lbColor := Color2RGB( Self_.fData.Brush.LineColor );
- end;
- end;
- Self_.fHandle := CreateBrushIndirect(LogBrush);
- {$endif wince}
- {$IFDEF DEBUG_GDIOBJECTS}
- if Self_.fHandle <> 0 then
- Inc( BrushCount )
- else
- ShowMessage( 'Could not create brush, error ' + Int2Str( GetLastError ) +
- ': ' + SysErrorMessage( GetLastError ) );
- {$ENDIF}
- end;
- Result := Self_.fHandle;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeBrushHandle]
-
- {$UNDEF ASM_LOCAL}
- {$IFNDEF UNICODE_CTRLS}
- {$IFDEF ASM_VERSION}
- {$IFNDEF AUTO_REPLACE_CLEARTYPE}
- {$DEFINE ASM_LOCAL}
- {$ENDIF AUTO_REPLACE_CLEARTYPE}
- {$ENDIF ASM_VERSION}
- {$ENDIF}
-
- //[FUNCTION MakeFontHandle]
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- function MakeFontHandle( Self_: PGraphicTool ): THandle;
- {$IFDEF AUTO_REPLACE_CLEARTYPE}
- var LF: TLogFont;
- {$ENDIF}
- begin
- with Self_{-}^{+} do
- begin
- if fHandle = 0 then
- begin
- {$IFDEF AUTO_REPLACE_CLEARTYPE}
- Move( fData.Font, LF, Sizeof( LF ) );
- if WinVer < wvXP then
- begin
- if LF.lfQuality > ANTIALIASED_QUALITY then
- LF.lfQuality := ANTIALIASED_QUALITY;
- end;
- fHandle := CreateFontIndirect( LF );
- {$ELSE}
- fHandle := CreateFontIndirect( PLogFont( @ fData.Font )^ );
- {$ENDIF}
- {$IFDEF DEBUG_GDIOBJECTS}
- Inc( FontCount );
- {$ENDIF}
- end;
- Result := fHandle;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeFontHandle]
-
- //[FUNCTION MakePenHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakePenHandle( Self_: PGraphicTool ): THandle;
- var
- LogPen: TLogPen;
- begin
- with Self_{-}^{+} do
- begin
- //GlobalGraphics_OnObjectCreating( @Self );
- if fHandle = 0 then
- with LogPen do
- begin
- lopnStyle := Byte( fData.Pen.Style );
- lopnWidth.X := fData.Pen.Width;
- lopnColor := Color2RGB( fData.Color );
- fHandle := CreatePenIndirect( LogPen );
- {$IFDEF DEBUG_GDIOBJECTS}
- Inc( PenCount );
- {$ENDIF}
- end;
- //GlobalGraphics_OnObjectCreated( @Self );
- Result := fHandle;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakePenHandle]
-
- //+
-
- //[function GetGeometricPen]
- function TGraphicTool.GetGeometricPen: Boolean;
- begin
- Result := fData.Pen.Geometric; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetGeometricPen]
- procedure TGraphicTool.SetGeometricPen(const Value: Boolean);
- begin
- if fData.Pen.Geometric = Value then Exit;
- fData.Pen.Geometric := Value;
- fMakeHandleProc := MakeGeometricPenHandle;
- Changed;
- end;
-
- //[function TGraphicTool.GetPenEndCap]
- function TGraphicTool.GetPenEndCap: TPenEndCap;
- begin
- Result := fData.Pen.EndCap; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetPenEndCap]
- procedure TGraphicTool.SetPenEndCap(const Value: TPenEndCap);
- begin
- if fData.Pen.EndCap = Value then Exit;
- fData.Pen.EndCap := Value;
- Changed;
- end;
-
- //[function TGraphicTool.GetPenJoin]
- function TGraphicTool.GetPenJoin: TPenJoin;
- begin
- Result := fData.Pen.Join; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetPenJoin]
- procedure TGraphicTool.SetPenJoin(const Value: TPenJoin);
- begin
- if fData.Pen.Join = Value then Exit;
- fData.Pen.Join := Value;
- Changed;
- end;
-
- //[FUNCTION MakeGeometricPenHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakeGeometricPenHandle( Self_: PGraphicTool ): THandle;
- {$ifndef wince}
- const
- PenEndCapStyles: array[ TPenEndCap ] of Word =
- (PS_ENDCAP_ROUND, PS_ENDCAP_SQUARE, PS_ENDCAP_FLAT);
- PenJoinStyles: array[ TPenJoin ] of Word =
- (PS_JOIN_ROUND, PS_JOIN_BEVEL, PS_JOIN_MITER );
- var
- LogBrush: TLogBrush;
- {$endif wince}
- begin
- if Self_.fHandle = 0 then
- {$ifdef wince}
- Self_.fHandle := CreatePen(Byte( Self_.fData.Pen.Style ), Self_.fData.Pen.Width, Color2RGB( Self_.fData.Color ));
- {$else}
- with Self_{-}^{+}, LogBrush do
- begin
- lbColor := Color2RGB( fData.Color );
- lbHatch := 0;
- if fData.Pen.BrushBitmap <> 0 then
- begin
- lbStyle := BS_PATTERN;
- lbHatch := fData.Pen.BrushBitmap;
- end
- else
- case fData.Pen.BrushStyle of
- bsSolid: lbStyle := BS_SOLID;
- bsClear: lbStyle := BS_NULL;
- else begin
- lbStyle := BS_HATCHED;
- case fData.Pen.BrushStyle of
- bsHorizontal: lbHatch := HS_HORIZONTAL;
- bsVertical: lbHatch := HS_VERTICAL;
- bsFDiagonal: lbHatch := HS_FDIAGONAL;
- bsBDiagonal: lbHatch := HS_BDIAGONAL;
- bsCross: lbHatch := HS_CROSS;
- bsDiagCross: lbHatch := HS_DIAGCROSS;
- end;
- end;
- end;
- Self_.fHandle := ExtCreatePen( PS_GEOMETRIC or Byte( Self_.fData.Pen.Style ) or
- PenEndCapStyles[ Self_.fData.Pen.EndCap ] or
- PenJoinStyles[ Self_.fData.Pen.Join ],
- Self_.fData.Pen.Width, LogBrush, 0, nil );
- {Assert( Self_.fHandle <> 0, 'Error ' + Int2Str( GetLastError ) +
- ': ' + SysErrorMessage( GetLastError ) );}
- end;
- {$endif wince}
- {$IFDEF DEBUG_GDIOBJECTS}
- Inc( PenCount );
- {$ENDIF}
- Result := Self_.fHandle;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeGeometricPenHandle]
-
- {$ENDIF WIN_GDI}
- //[function TGraphicTool.GetFontWeight]
- function TGraphicTool.GetFontWeight: Integer;
- begin
- Result := fData.Font.Weight; // for BCB only
- end;
-
- //[procedure TGraphicTool.SetFontWeight]
- procedure TGraphicTool.SetFontWeight(const Value: Integer);
- begin
- if fData.Font.Weight = Value then Exit;
- fData.Font.Weight := Value;
- Changed;
- end;
- {$IFDEF WIN_GDI}
-
- //[procedure TGraphicTool.SetLogFontStruct]
- procedure TGraphicTool.SetLogFontStruct(const Value: TLogFont);
- begin
- if CompareMem(@fData.Font, @Value, SizeOf(TLogFont)) then Exit;
- Move(Value, fData.Font, SizeOF(TLogFont));
- Changed;
- end;
-
- //[function TGraphicTool.GetLogFontStruct]
- function TGraphicTool.GetLogFontStruct: TLogFont;
- begin
- Move(fData.Font, Result, SizeOf(TLogFont));
- end;
- {$ENDIF WIN_GDI}
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TGraphicTool.GetPangoFontDesc: PPangoFontDescription;
- var s: String;
- i: Integer;
- function IfThen( cond: Boolean; const s: String ): String;
- begin
- Result := '';
- if cond then Result := s;
- end;
- {const Weights: array[0..9] of String = ( 'Ultralight',
- 'Ultralight', 'Ultralight',
- 'Light', 'Normal', 'Normal', 'Normal',
- 'Bold', 'Ultrabold', 'Heavy' );}
- begin
- if not Assigned( fPangoFontDesc ) then
- begin
- s := FontName; { + ' ' +
- IfThen( FontWeight <> 400, Weights[ FontWeight div 100 ] + ' ' ) +
- IfThen( fsItalic in FontStyle, 'Italic ' ) +
- Int2Str( FontHeight )};
- fPangoFontDesc := pango_font_description_from_string( PChar( s ) );
- i := FontHeight;
- if i > 0 then
- pango_font_description_set_absolute_size( fPangoFontDesc, i * PANGO_SCALE );
- //i := pango_font_description_get_size( fPangoFontDesc );
- i := PANGO_STYLE_NORMAL;
- if fsItalic in FontStyle then i := PANGO_STYLE_ITALIC;
- pango_font_description_set_style( fPangoFontDesc, i );
- pango_font_description_set_weight( fPangoFontDesc, FontWeight );
- end;
- Result := fPangoFontDesc;
- end;
-
- function Color2GDKColor( Color: TColor ): TGdkColor;
- begin
- Color := Color2RGB( Color );
- Result.pixel := 0;
- Result.red := (Color and $FF) shl 8;
- Result.green := Color and $FF00;
- Result.blue := (Color shr 8) and $FF00;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- { TCanvas }
-
- type
- TStock = {$ifndef wince}packed{$endif} Record
- StockPen: HPEN;
- StockBrush: HBRUSH;
- StockFont: HFONT;
- end;
-
- var
- Stock: TStock;
-
- //[destructor TCanvas.Destroy]
- destructor TCanvas.Destroy;
- begin
- Handle := 0;
- fPen.Free;
- fBrush.Free;
- fFont.Free;
- inherited;
- end;
-
- //[function TCanvas.Assign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.Assign(SrcCanvas: PCanvas): Boolean;
- begin
- fFont := fFont.Assign( SrcCanvas.fFont );
- fBrush := fBrush.Assign( SrcCanvas.fBrush );
- fPen := fPen.Assign( SrcCanvas.fPen );
- AssignChangeEvents;
- Result := (fFont <> nil) or (fBrush <> nil) or (fPen <> nil);
- if (SrcCanvas.PenPos.x <> PenPos.x) or (SrcCanvas.PenPos.y <> PenPos.y) then
- begin
- Result := True;
- PenPos := SrcCanvas.PenPos;
- end;
- if SrcCanvas.ModeCopy <> ModeCopy then
- begin
- Result := True;
- ModeCopy := SrcCanvas.ModeCopy;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.CreateBrush]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.CreateBrush;
- begin
- if assigned( fBrush ) then
- begin
- SelectObject( GetHandle, fBrush.Handle );
- AssignChangeEvents;
- if fBrush.fData.Brush.Style = bsSolid then
- begin
- SetBkColor( fHandle, Color2RGB( fBrush.fData.Color ) );
- SetBkMode( fHandle, OPAQUE );
- end
- else
- begin
- { Win95 doesn't draw brush hatches if bkcolor = brush color }
- { Since bkmode is transparent, nothing should use bkcolor anyway }
- SetBkColor( fHandle, not Color2RGB( fBrush.fData.Color ) );
- SetBkMode( fHandle, TRANSPARENT );
- end;
- end
- else
- if Assigned( fOwnerControl ) then
- begin
- SetBkColor( GetHandle, Color2RGB( PControl( fOwnerControl ).fColor ) );
- SetBkMode( fHandle, OPAQUE );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.CreateFont]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.CreateFont;
- begin
- if assigned( fFont ) then
- begin
- SelectObject( GetHandle, fFont.Handle );
- SetTextColor( fHandle, Color2RGB( fFont.fData.Color ) );
- AssignChangeEvents;
- end
- else
- if Assigned( fOwnerControl ) then
- begin
- SetTextColor( fHandle, Color2RGB( PControl( fOwnerControl ).fTextColor ) );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.CreatePen]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.CreatePen;
- begin
- if assigned( fPen ) then
- begin
- SelectObject( GetHandle, fPen.Handle );
- SetROP2( fHandle, Ord( fPen.fData.Pen.Mode ) + 1 );
- AssignChangeEvents;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TCanvas.GetPixels]
- function TCanvas.GetPixels(X, Y: Integer): TColor;
- begin
- RequiredState( HandleValid );
- Result := Windows.GetPixel(FHandle, X, Y);
- end;
-
- //[procedure TCanvas.SetPixels]
- procedure TCanvas.SetPixels(X, Y: Integer; const Value: TColor);
- begin
- Changing;
- RequiredState( HandleValid );
- Windows.SetPixel(FHandle, X, Y, Color2RGB( Value ));
- end;
- {$ENDIF WIN_GDI}
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.SaveState;
- begin
- gdk_gc_get_values( fHandle, @ fSavedState );
- end;
-
- procedure TCanvas.RestoreState;
- var mask: DWORD;
- begin
- mask := $1FFFF;
- if fSavedState.font = nil then mask := mask and not GDK_GC_FONT;
- if fSavedState.stipple = nil then mask := mask and not GDK_GC_STIPPLE;
- gdk_gc_set_values( fHandle, @ fSavedState, mask );
- DeselectHandles;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.DeselectHandles]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.DeselectHandles;
- begin
- if (fHandle <> 0) and
- LongBool(fState and (PenValid or BrushValid or FontValid)) then
- with Stock do
- begin
- if StockPen = 0 then
- begin
- StockPen := GetStockObject(BLACK_PEN);
- StockBrush := GetStockObject(HOLLOW_BRUSH);
- StockFont := GetStockObject(SYSTEM_FONT);
- end;
- SelectObject( fHandle, StockPen );
- SelectObject( fHandle, StockBrush );
- SelectObject( fHandle, StockFont );
- fState := fState and not( PenValid or BrushValid or FontValid );
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.DeselectHandles;
- begin
- {$IFDEF GDI}
- Free_And_Nil( fBrush );
- Free_And_Nil( fPen );
- Free_And_Nil( fFont );
- {$ENDIF GDI}
- if Assigned( fFont ) and Assigned( fFont.fPangoFontDesc ) then
- begin
- pango_font_description_free( fFont.fPangoFontDesc );
- fFont.fPangoFontDesc := nil;
- end;
- fState := fState and not( PenValid or BrushValid or FontValid );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //[function TCanvas.RequiredState]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.RequiredState(ReqState: DWORD): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var
- NeededState: Byte;
- begin
- if Boolean(ReqState and ChangingCanvas) then
- Changing;
- ReqState := ReqState and 15;
- NeededState := Byte( ReqState ) and not fState;
- Result := 0;
- if Boolean(ReqState and HandleValid) then
- begin
- if GetHandle = 0 then Exit; // Important!
- end;
- if NeededState <> 0 then
- begin
- if Boolean( NeededState and FontValid ) then
- CreateFont;
- if Boolean( NeededState and PenValid ) then
- begin
- CreatePen;
- if assigned( fPen ) then
- if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
- NeededState := NeededState or BrushValid;
- end;
- if Boolean( NeededState and BrushValid ) then
- CreateBrush;
- fState := fState or NeededState;
- end;
- Result := fHandle;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- (*function TCanvas.RequiredState(ReqState: DWORD): HDC; {$ifdef wince}cdecl{$else}stdcall{$endif}; //todo:
- var NeededState: Byte;
- //var c: TGdkColor;
- begin
- {if Boolean(ReqState and ChangingCanvas) then
- Changing;}
- ReqState := ReqState and (BrushValid or FontValid or PenValid);
- NeededState := Byte( ReqState ) and not fState;
- //Result := nil;
- { if Boolean(ReqState and HandleValid) then
- begin
- if GetHandle = 0 then Exit; // Important!
- end;}
- if NeededState <> 0 then
- begin
- if Boolean( NeededState and PenValid ) then
- begin
- //CreatePen;
- if not assigned( fPen ) then
- fPen := NewPen;
- if fPen.fData.Pen.Style in [psDash, psDot, psDashDot, psDashDotDot] then
- NeededState := NeededState or BrushValid;
- end;
- if Boolean( NeededState and BrushValid ) then
- begin
- //CreateBrush;
- if not Assigned( fBrush ) then
- fBrush := NewBrush;
- //c := Color2GDKColor( fBrush.Color );
- //gdk_gc_set_rgb_fg_color( fHandle, @ c );
- //todo: what with BrushBitmap and BrushStyle ?
- end;
- if Boolean( NeededState and FontValid ) then
- begin
- //CreateFont;
- if not Assigned( fFont ) then
- fFont := NewFont;
- end;
- fState := fState or NeededState;
- end;
- Result := fHandle;
- end;*)
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.ForeBack(fg_color, bk_color: TColor); // install colors just before drawing
- begin
- fg_color := RGB2BGR( Color2RGB( fg_color ) );
- bk_color := RGB2BGR( Color2RGB( bk_color ) );
- gdk_rgb_gc_set_foreground( fHandle, fg_color );
- gdk_rgb_gc_set_background( fHandle, bk_color );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
-
- //[procedure TCanvas.SetHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.SetHandle(Value: HDC);
- {$IFDEF F_P}
- var Ptr1: Pointer;
- {$ENDIF F_P}
- begin
- if fHandle = Value then Exit;
- if fHandle <> 0 then
- begin
- DeselectHandles;
- {$IFDEF GDI}
- if not( assigned(fOwnerControl) and
- (PControl(fOwnerControl).fPaintDC = fHandle) ) then
- begin
- {$IFDEF F_P}
- Ptr1 := Self;
- asm
- MOV EAX, [Ptr1]
- MOV EAX, [EAX].TCanvas.fOnGetHandle
- MOV [Ptr1], EAX
- end [ 'EAX' ];
- if Ptr1 = @ TControl.DC2Canvas then
- {$ELSE DELPHI}
- //////////////////// SLAG
- if TMethod(fOnGetHandle).Code =
- @TControl.Dc2Canvas then
- {$ENDIF F_P/DELPHI}
- ReleaseDC(PControl(fOwnerControl).Handle, fHandle )
- else
- DeleteDC( fHandle );
- ////////////////////
- end;
- {$ENDIF GDI}
- fHandle := 0;
- fIsPaintDC := False;
- fState := fState and not HandleValid;
- end;
- if Value <> 0 then
- begin
- fState := fState or HandleValid;
- fHandle := Value;
- SetPenPos( fPenPos );
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- //[procedure TCanvas.SetPenPos]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.SetPenPos(const Value: TPoint);
- begin
- fPenPos := Value;
- {$IFDEF GDI}
- MoveTo( Value.x, Value.y );
- {$ENDIF GDI}
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- //[procedure TCanvas.Changing]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Changing;
- begin
- if Assigned( fOnChange ) then
- fOnChange( @Self );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[procedure TCanvas.Arc]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- RequiredState( HandleValid or PenValid or ChangingCanvas );
- {$ifndef wince}
- Windows.Arc(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- var C: TPoint;
- angle1, angle2: Integer;
- A1, A2: Double;
- begin
- ////RequiredState( {HandleValid or} PenValid or ChangingCanvas );
- C := MakePoint( (X1 + X2) div 2, (Y1 + Y2) div 2 );
- {$IFDEF NOT_USE_EXCEPTION}
- A1 := ArcTan2( Y3-C.Y, X3-C.X );
- A2 := ArcTan2( Y4-C.Y, X4-C.X );
- {$ELSE USE_EXCEPTION}
- TRY
- A1 := ArcTan2( Y3-C.Y, X3-C.X );
- EXCEPT
- A1 := 0;
- END;
- TRY
- A2 := ArcTan2( Y4-C.Y, X4-C.X );
- EXCEPT
- A2 := 0;
- END;
- {$ENDIF NOT_USE_EXCEPTION}
- angle1 := -Round(A1 * 180 * 64 / PI);
- angle2 := -Round(A2 * 180 * 64 / PI);
- if Brush.BrushStyle <> bsClear then
- begin
- ForeBack( Brush.Color, Brush.Color );
- gdk_draw_arc( fDrawable, fHandle, 1, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
- end;
- ForeBack( Pen.Color, Brush.Color );
- gdk_draw_arc( fDrawable, fHandle, 0, X1, Y1, X2-X1, Y2-Y1, angle1, angle2 );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //[procedure TCanvas.Chord]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- {$ifndef wince}
- Windows.Chord(FHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.CopyRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.CopyRect(const DstRect: TRect; SrcCanvas: PCanvas;
- const SrcRect: TRect);
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- SrcCanvas.RequiredState( HandleValid or BrushValid );
- StretchBlt( fHandle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
- DstRect.Bottom - DstRect.Top, SrcCanvas.Handle, SrcRect.Left, SrcRect.Top,
- SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, ModeCopy);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.DrawFocusRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.DrawFocusRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- begin
- RequiredState( HandleValid or BrushValid or FontValid or ChangingCanvas );
- Windows.DrawFocusRect(FHandle, Rect);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.Ellipse]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Ellipse(X1, Y1, X2, Y2: Integer);
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- Windows.Ellipse(FHandle, X1, Y1, X2, Y2);
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[procedure TCanvas.FillRect]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- var Br: HBrush;
- begin
- RequiredState( HandleValid or BrushValid or ChangingCanvas );
- if assigned( fBrush ) then
- begin
- Windows.FillRect(fHandle, Rect, fBrush.Handle);
- end
- else
- if assigned( fOwnerControl ) then
- begin
- {$IFDEF GDI}
- if assigned( PControl( fOwnerControl ).fBrush ) then
- Windows.FillRect( fHandle, Rect, PControl( fOwnerControl ).fBrush.Handle )
- else
- begin
- Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
- Windows.FillRect(fHandle, Rect, Br );
- DeleteObject( Br );
- end;
- {$ENDIF GDI}
- end
- else
- begin
- Windows.FillRect(fHandle, Rect, HBrush(COLOR_WINDOW + 1) );
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.FillRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- begin
- if (fBrush <> nil) and (fBrush.BrushStyle = bsClear) then Exit;
- ////RequiredState( {HandleValid or} BrushValid or ChangingCanvas );
- ForeBack( Brush.Color, Brush.Color );
- gdk_draw_rectangle( fDrawable, fHandle, 1, Rect.Left, Rect.Top,
- Rect.Right-Rect.Left, Rect.Bottom-Rect.Top );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //[procedure TCanvas.FillRgn]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.FillRgn(const Rgn: HRgn);
- var Br : HBrush;
- begin
- RequiredState( HandleValid or BrushValid or ChangingCanvas );
- if assigned( fBrush ) then
- Windows.FillRgn(FHandle, Rgn, fBrush.Handle )
- else
- if assigned( fOwnerControl ) then
- begin
- {$IFDEF GDI}
- if Assigned( PControl( fOwnerControl ).fBrush ) then
- Windows.FillRgn( FHandle, Rgn, PControl( fOwnerControl ).fBrush.Handle )
- else
- begin
- Br := CreateSolidBrush( Color2RGB(PControl(fOwnerControl).fColor) );
- Windows.FillRgn( fHandle, Rgn, Br );
- DeleteObject( Br );
- end;
- {$ENDIF GDI}
- end
- else
- begin
- Br := CreateSolidBrush( DWORD(clWindow) );
- Windows.FillRgn( fHandle, Rgn, Br );
- DeleteObject( Br );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.FloodFill]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.FloodFill(X, Y: Integer; Color: TColor;
- FillStyle: TFillStyle);
- {$ifndef wince}
- const
- FillStyles: array[TFillStyle] of Word =
- (FLOODFILLSURFACE, FLOODFILLBORDER);
- {$endif wince}
- begin
- RequiredState( HandleValid or BrushValid or ChangingCanvas );
- {$ifndef wince}
- Windows.ExtFloodFill(FHandle, X, Y, Color, FillStyles[FillStyle]);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- {$ifdef wince}
- procedure CeFrameRect(DC: HDC; const Rect: TRect; Color: TColor);
- var
- OldBrush, OldPen : HGDIOBJ;
- begin
- OldBrush:=SelectObject(DC, GetStockObject(NULL_BRUSH));
- OldPen:=SelectObject(DC, Windows.CreatePen(PS_SOLID, 1, Color2RGB(Color)));
- with Rect do
- Windows.Rectangle(DC, Left, Top, Right, Bottom);
- DeleteObject( SelectObject(DC, OldPen) );
- SelectObject(DC, OldBrush);
- end;
- {$endif wince}
- //[procedure TCanvas.FrameRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.FrameRect({$IFNDEF FPC}const{$ENDIF} Rect: TRect);
- var {$ifdef win32}SolidBr : HBrush;{$endif}
- col : TColor;
- begin
- RequiredState( HandleValid or ChangingCanvas );
- if assigned( fBrush ) then
- col := fBrush.fData.Color
- else
- if assigned( fOwnerControl ) then
- col := PControl(fOwnerControl).fColor
- else
- col := clWhite;
- {$ifdef wince}
- CeFrameRect(FHandle, Rect, col);
- {$else}
- SolidBr := CreateSolidBrush( Color2RGB(col) );
- Windows.FrameRect(FHandle, Rect, SolidBr);
- DeleteObject( SolidBr );
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[procedure TCanvas.LineTo]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.LineTo(X, Y: Integer);
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- Windows.LineTo( fHandle, X, Y );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.LineTo(X, Y: Integer);
- begin
- //RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- ////RequiredState( PenValid or BrushValid or ChangingCanvas );
- ForeBack( Pen.Color, Brush.Color );
- gdk_draw_line( fDrawable, fHandle, fPenPos.X, fPenPos.Y, X, Y );
- fPenPos := MakePoint( X, Y );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.MoveTo]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.MoveTo(X, Y: Integer);
- begin
- RequiredState( HandleValid );
- Windows.MoveToEx( fHandle, X, Y, nil );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.MoveTo(X, Y: Integer);
- begin
- fPenPos := MakePoint( X, Y );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.ObjectChanged]
- procedure TCanvas.ObjectChanged(Sender: PGraphicTool);
- begin
- DeselectHandles;
- end;
-
- {$IFDEF WIN_GDI}
- //[procedure TCanvas.Pie]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- {$ifndef wince}
- Windows.Pie( fHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
-
- {++}(*
- {$IFDEF F_P}
- //[Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]
- function Windows_Polygon; external gdi32 name 'Polygon';
- function Windows_Polyline; external gdi32 name 'Polyline';
- function FillRect; external user32 name 'FillRect';
- function OffsetRect; external user32 name 'OffsetRect';
- function CreateAcceleratorTable; external user32 name 'CreateAcceleratorTableA';
- function TrackPopupMenu; external user32 name 'TrackPopupMenu';
- function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
- const NewState: TTokenPrivileges; BufferLength: DWORD;
- var PreviousState: TTokenPrivileges; var ReturnLength: DWORD): BOOL; external advapi32 name 'AdjustTokenPrivileges';
- function InflateRect; external user32 name 'InflateRect';
- {$IFDEF F_P105ORBELOW}
- function InvalidateRect; external user32 name 'InvalidateRect';
- function ValidateRect; external user32 name 'ValidateRect';
- {$ENDIF F_P105ORBELOW}
- //[END OF Windows API FUNCTIONS ADDITIONAL DECLARATIONS FOR Free Pascal]
- {$ENDIF}
- *){--}
-
- //[procedure TCanvas.Polygon]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Polygon(const Points: array of TPoint);
- type
- PPoints = ^TPoints;
- TPoints = array[0..0] of TPoint;
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- {$IFDEF F_P} Windows_Polygon
- {$ELSE DELPHI} Windows.Polygon
- {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.Polyline]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Polyline(const Points: array of TPoint);
- type
- PPoints = ^TPoints;
- TPoints = array[0..0] of TPoint;
- begin
- RequiredState( HandleValid or PenValid or BrushValid or ChangingCanvas );
- {$IFDEF F_P}Windows_Polyline
- {$ELSE DELPHI}Windows.Polyline
- {$ENDIF}( fHandle, PPoints(@Points)^, High(Points) + 1);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.Rectangle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer);
- begin
- RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
- Windows.Rectangle( fHandle, X1, Y1, X2, Y2);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TCanvas.RoundRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
- begin
- RequiredState( HandleValid or BrushValid or PenValid or ChangingCanvas );
- Windows.RoundRect( fHandle, X1, Y1, X2, Y2, X3, Y3);
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- //[procedure TCanvas.TextArea]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.TextArea(const Text: KOLString; var Sz: TSize;
- var P0: TPoint);
- begin
- Sz := TextExtent( Text );
- P0.x := 0; P0.y := 0;
- if Assigned( GlobalCanvas_OnTextArea ) then
- GlobalCanvas_OnTextArea( @Self, Sz, P0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TCanvas.TextExtent]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.TextExtent(const Text: KOLString): TSize;
- var DC : HDC;
- ClearHandle : Boolean;
- begin
- ClearHandle := False;
- RequiredState( HandleValid or FontValid );
- DC := fHandle;
- if DC = 0 then
- begin
- DC := CreateCompatibleDC( 0 );
- ClearHandle := True;
- SetHandle( DC );
- If Not fIsPaintDC then
- ClearHandle := True; //************ // Added By Gerasimov
- end;
- RequiredState( HandleValid or FontValid );
- {Windows.}GetTextExtentPoint32( fHandle, PKOLChar(Text), Length(Text), Result);
- {$ifdef wince}
- Inc(Result.cx);
- {$endif wince}
- if ClearHandle then
- SetHandle( 0 );
- { DC must be freed here automatically (never leaks):
- if Canvas created on base of existing DC, no memDC created,
- if Canvas has fHandle:HDC = 0, it is not fIsPaintDC always. }
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TCanvas.TextExtent(const Text: KOLString): TSize;
- var layout: PPangoLayout;
- context: PPangoContext;
- begin
- //RequiredState( HandleValid or FontValid );
- if fOwnerControl <> nil then
- begin
- context := nil;
- layout := gtk_widget_create_pango_layout(
- PControl( fOwnerControl ).fEventboxHandle, nil );
- end
- else
- begin //todo: seems not working in such way... What to do for memory bitmap?
- context := pango_context_new;
- //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
- layout := pango_layout_new( context );
- end;
- pango_layout_set_font_description( layout, Font.FontHandle );
- pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
- pango_layout_get_size( layout, @ Result.cx, @ Result.cy );
- g_object_unref( layout );
- if context <> nil then g_object_unref( context );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[function TCanvas.TextHeight]
- function TCanvas.TextHeight(const Text: KOLString): Integer;
- begin
- Result := TextExtent(Text).cY;
- end;
-
- //[procedure TCanvas.TextOut]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$ifdef wince}
- var Options: Integer;
- {$endif wince}
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- {$ifdef wince}
- Options := 0;
- if GetBkMode(FHandle) = OPAQUE then Options := ETO_OPAQUE;
- Windows.ExtTextOut(FHandle, X, Y, Options, nil, PKOLChar(Text), Length(Text), nil);
- {$else}
- Windows.TextOut(FHandle, X, Y, PChar(Text), Length(Text));
- {$endif wince}
- //MoveTo(X + TextWidth(Text), Y); -- by suggestion of Alexey (Lecha2002)
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.TextOut(X, Y: Integer; const Text: KOLString); {$ifdef wince}cdecl{$else}stdcall{$endif};
- var Options: Integer;
- begin
- Options := 0;
- if Brush.BrushStyle <> bsClear then Options := ETO_OPAQUE;
- ExtTextOut( X, Y, Options, MakeRect( 0,0,0,0 ), Text, [ ] );
- end;
- (*var context: PPangoContext;
- layout: PPangoLayout;
- w, h: Integer;
- begin
- RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas );
- if fOwnerControl <> nil then
- begin
- context := nil;
- layout := gtk_widget_create_pango_layout(
- PControl( fOwnerControl ).fEventboxHandle, nil );
- end
- else
- begin //todo: seems not working in such way... What to do for memory bitmap?
- context := pango_context_new;
- //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
- layout := pango_layout_new( context );
- end;
- pango_layout_set_font_description( layout, Font.FontHandle );
- pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
- if Brush.BrushStyle <> bsClear then
- begin
- pango_layout_get_size( layout, @ w, @ h );
- ForeBack( Brush.Color, Brush.Color );
- gdk_draw_rectangle( fDrawable, fHandle, 1, X, Y, w div PANGO_SCALE, h div PANGO_SCALE );
- end;
- ForeBack( Font.Color, Brush.Color );
- gdk_draw_layout( fDrawable, fHandle, X, Y, layout );
- g_object_unref( layout );
- if context <> nil then
- g_object_unref( context );
- end;*)
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.TextRect]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: KOLString);
- var
- Options: Integer;
- begin
- //Changing;
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Options := ETO_CLIPPED;
- if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)
- or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);
- Windows.
- {$IFDEF UNICODE_CTRLS}
- ExtTextOutW
- {$ELSE}
- ExtTextOut
- {$ENDIF}
- ( fHandle, X, Y, Options,
- @Rect, PKOLChar(Text),
- Length(Text), nil);
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.TextRect(const Rect: TRect; X, Y: Integer; const Text: string);
- var Options: Integer;
- begin
- Options := ETO_CLIPPED;
- if Brush.BrushStyle <> bsClear then Options := Options or ETO_OPAQUE;
- ExtTextOut( X, Y, Options, Rect, Text, [] );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.ExtTextOut]
- {$IFDEF GDI}
- procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
- const Spacing: array of Integer );
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Windows.
- {$IFDEF UNICODE_CTRLS}
- ExtTextOutW
- {$ELSE}
- ExtTextOut
- {$ENDIF}
- (FHandle, X, Y, Options, @Rect, PKOLChar(Text), Length(Text), @Spacing[ 0 ]);
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TCanvas.ExtTextOut( X, Y: Integer; Options: DWORD; const Rect: TRect; const Text: KOLString;
- const Spacing: array of Integer );
- var context: PPangoContext;
- layout: PPangoLayout;
- w, h: Integer;
- pixmap: PGdkPixmap;
- begin
- ////RequiredState( {HandleValid or} FontValid or BrushValid or ChangingCanvas );
- w := Rect.Right - Rect.Left;
- h := Rect.Bottom - Rect.Top;
- if fOwnerControl <> nil then
- begin
- context := nil;
- layout := gtk_widget_create_pango_layout(
- PControl( fOwnerControl ).fEventboxHandle, nil );
- end
- else
- begin //todo: seems not working in such way... What to do for memory bitmap?
- context := pango_context_new;
- //layout := gtk_widget_create_pango_layout( fHandle, PChar( Text ) );
- layout := pango_layout_new( context );
- end;
- pango_layout_set_font_description( layout, Font.FontHandle );
- pango_layout_set_text( layout, PChar( Text ), Length( Text ) );
- if Options and ETO_CLIPPED = 0 then
- begin
- pango_layout_get_size( layout, @ w, @ h );
- w := w div PANGO_SCALE;
- h := h div PANGO_SCALE;
- end;
- pixmap := gdk_pixmap_new( PControl( fOwnerControl ).fEventboxHandle.window,
- //todo: use MainForm
- w, h, -1 );
- if Options and ETO_OPAQUE <> 0 then
- begin
- ForeBack( Brush.Color, Brush.Color );
- gdk_draw_rectangle( GDK_DRAWABLE( pixmap ), fHandle, 1, 0, 0, w, h );
- end
- else
- begin
- gdk_draw_drawable( GDK_DRAWABLE( pixmap ), fHandle, fDrawable,
- Rect.Left, Rect.Top, 0, 0, w, h );
- end;
- ForeBack( Font.Color, Brush.Color );
- gdk_draw_layout( GDK_DRAWABLE( pixmap ), fHandle, X, Y, layout );
- g_object_unref( layout );
- gdk_draw_drawable( fDrawable, fHandle, GDK_DRAWABLE( pixmap ),
- 0, 0, Rect.Left, Rect.Top, w, h );
- g_object_unref( pixmap );
- if context <> nil then
- g_object_unref( context );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //[procedure TCanvas.DrawText]
- procedure TCanvas.DrawText(Text:KOLString; var Rect:TRect; Flags:DWord);
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Windows.
- {$IFDEF UNICODE_CTRLS}
- DrawTextW
- {$ELSE}
- DrawText
- {$ENDIF}
- (Handle,PKOLChar(Text),Length(Text),Rect,Flags);
- end;
-
- //[function TCanvas.ClipRect]
- function TCanvas.ClipRect: TRect;
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- GetClipBox(Handle, Result);
- end;
- {$ENDIF WIN_GDI}
-
- //[function TCanvas.TextWidth]
- function TCanvas.TextWidth(const Text: KOLString): Integer;
- begin
- Result := TextExtent(Text).cX;
- end;
-
- //[function TCanvas.GetBrush]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.GetBrush: PGraphicTool;
- begin
- if not assigned( fBrush ) then
- begin
- fBrush := NewBrush;
- if assigned( fOwnerControl ) then
- begin
- fBrush.fData.Color := PControl(fOwnerControl).fColor;
- if assigned( PControl(fOwnerControl).fBrush ) then
- {fBrush := }fBrush.Assign( PControl(fOwnerControl).fBrush );
- // both statements above needed
- end;
- //fBrush.OnChange := ObjectChanged;
- AssignChangeEvents;
- end;
- Result := fBrush;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TCanvas.GetBrush: PGraphicTool;
- begin
- if not assigned( fBrush ) then
- begin
- fBrush := NewBrush;
- if assigned( fOwnerControl ) then
- begin
- fBrush.fData.Color := PControl(fOwnerControl).fColor;
- if assigned( PControl(fOwnerControl).fBrush ) then
- {fBrush := }fBrush.Assign( PControl(fOwnerControl).fBrush );
- // both statements above needed
- end;
- //fBrush.OnChange := ObjectChanged;
- AssignChangeEvents;
- end;
- Result := fBrush;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[function TCanvas.GetFont]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.GetFont: PGraphicTool;
- begin
- if not assigned( fFont ) then
- begin
- fFont := NewFont;
- if assigned( fOwnerControl ) then
- begin
- fFont.Color := PControl(fOwnerControl).fTextColor;
- if assigned( PControl(fOwnerControl).fFont ) then
- {fFont := }fFont.Assign( PControl(fOwnerControl).fFont );
- end;
- //fFont.OnChange := ObjectChanged;
- AssignChangeEvents;
- end;
- Result := fFont;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TCanvas.GetPen]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.GetPen: PGraphicTool;
- begin
- if not assigned( fPen ) then
- begin
- fPen := NewPen;
- AssignChangeEvents;
- end;
- Result := fPen;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TCanvas.GetHandle]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TCanvas.GetHandle: HDC;
- begin
- if assigned( fOnGetHandle ) then
- begin
- Result := fOnGetHandle( @Self );
- //fHandle := Result;
- SetHandle( Result );
- end
- else
- Result := fHandle;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TCanvas.GetHandle: HDC;
- begin
- if Assigned( fOnGetHandle ) then
- fHandle := fOnGetHandle( @Self );
- Result := fHandle;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TCanvas.AssignChangeEvents]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TCanvas.AssignChangeEvents;
- begin
- if assigned( fBrush ) then
- fBrush.fOnChange := ObjectChanged;
- if assigned( fPen ) then
- fPen.fOnChange := ObjectChanged;
- if assigned( fFont ) then
- fFont.fOnChange := ObjectChanged;
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- //[procedure TCanvas.WDrawText]
- procedure TCanvas.WDrawText(WText: WideString; var Rect: TRect;
- Flags: DWord);
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Windows.DrawTextW(Handle,PWideChar(WText),Length(WText),Rect,Flags);
- end;
-
- //[procedure TCanvas.WExtTextOut]
- procedure TCanvas.WExtTextOut(X, Y: Integer; Options: DWORD;
- const Rect: TRect; const WText: WideString;
- const Spacing: array of Integer);
- begin
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Windows.ExtTextOutW(FHandle, X, Y, Options, @Rect, PWideChar(WText), Length(WText), @Spacing[ 0 ]);
- end;
-
- //[procedure TCanvas.WTextOut]
- procedure TCanvas.WTextOut(X, Y: Integer; const WText: WideString);
- begin
- {$ifdef wince}
- TextOut(X, Y, WText);
- {$else}
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Windows.TextOutW(FHandle, X, Y, PWideChar(WText), Length(WText));
- MoveTo(X + WTextWidth(WText), Y);
- {$endif wince}
- end;
-
- //[procedure TCanvas.WTextRect]
- procedure TCanvas.WTextRect(const Rect: TRect; X, Y: Integer;
- const WText: WideString);
- var
- Options: Integer;
- begin
- //Changing;
- RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- Options := ETO_CLIPPED;
- if assigned( fBrush ) and (fBrush.fData.Brush.Style <> bsClear)
- or not assigned( fBrush ) then Inc(Options, ETO_OPAQUE);
- Windows.ExtTextOutW( fHandle, X, Y, Options,
- @Rect, PWideChar(WText),
- Length(WText), nil);
- end;
-
- //[function TCanvas.WTextExtent]
- function TCanvas.WTextExtent(const WText: WideString): TSize;
- var DC : HDC;
- ClearHandle : Boolean;
- begin
- ClearHandle := False;
- RequiredState( HandleValid or FontValid );
- DC := fHandle;
- if DC = 0 then
- begin
- DC := CreateCompatibleDC( 0 );
- ClearHandle := True;
- SetHandle( DC );
- end;
- RequiredState( HandleValid or FontValid );
- {Windows.}GetTextExtentPoint32W( fHandle, PWideChar(WText), Length(WText), Result);
- if ClearHandle then
- SetHandle( 0 );
- end;
-
- //[function TCanvas.WTextHeight]
- function TCanvas.WTextHeight(const WText: WideString): Integer;
- begin
- Result := WTextExtent( WText ).cy;
- end;
-
- //[function TCanvas.WTextWidth]
- function TCanvas.WTextWidth(const WText: WideString): Integer;
- begin
- Result := WTextExtent( WText ).cx;
- end;
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- {$ENDIF WIN_GDI}
- {-}
- //[function MakeInt64]
- function MakeInt64( Lo, Hi: DWORD ): I64;
- begin
- Result.Lo := Lo;
- Result.Hi := Hi;
- end;
-
- //[function Int2Int64]
- {$IFDEF cpu86}
- function Int2Int64( X: Integer ): I64;
- asm
- MOV [EDX], EAX
- MOV ECX, EDX
- CDQ
- MOV [ECX+4], EDX
- end;
- {$ELSE cpu86} //Pascal
- function Int2Int64( X: Integer ): I64;
- begin
- Int64(Result):=X;
- end;
- {$ENDIF cpu86}
-
- //[procedure IncInt64]
- {$IFDEF cpu86}
- procedure IncInt64( var I64: I64; Delta: Integer );
- asm
- ADD [EAX], EDX
- ADC dword ptr [EAX+4], 0
- end;
- {$ELSE cpu86} //Pascal
- procedure IncInt64( var I64: I64; Delta: Integer );
- begin
- Inc(Int64(I64), Delta);
- end;
- {$ENDIF cpu86}
-
- //[procedure DecInt64]
- {$IFDEF cpu86}
- procedure DecInt64( var I64: I64; Delta: Integer );
- asm
- SUB [EAX], EDX
- SBB dword ptr [EDX], 0
- end;
- {$ELSE cpu86} //Pascal
- procedure DecInt64( var I64: I64; Delta: Integer );
- begin
- Dec(Int64(I64), Delta);
- end;
- {$ENDIF cpu86}
-
- //[function Add64]
- {$IFDEF cpu86}
- function Add64( const X, Y: I64 ): I64;
- asm
- PUSH ESI
- XCHG ESI, EAX
- LODSD
- ADD EAX, [EDX]
- MOV [ECX], EAX
- LODSD
- ADC EAX, [EDX+4]
- MOV [ECX+4], EAX
- POP ESI
- end;
- {$ELSE cpu86} //Pascal
- function Add64( const X, Y: I64 ): I64;
- begin
- Int64(Result):=Int64(X)+Int64(Y);
- end;
- {$ENDIF cpu86}
-
- //[function Sub64]
- {$IFDEF cpu86}
- function Sub64( const X, Y: I64 ): I64;
- asm
- PUSH ESI
- XCHG ESI, EAX
- LODSD
- SUB EAX, [EDX]
- MOV [ECX], EAX
- LODSD
- SBB EAX, [EDX+4]
- MOV [ECX+4], EAX
- POP ESI
- end;
- {$ELSE cpu86} //Pascal
- function Sub64( const X, Y: I64 ): I64;
- begin
- Int64(Result):=Int64(X)-Int64(Y);
- end;
- {$ENDIF cpu86}
-
- //[function Neg64]
- {$IFDEF cpu86}
- function Neg64( const X: I64 ): I64;
- asm
- MOV ECX, [EAX]
- NEG ECX
- MOV [EDX], ECX
- MOV ECX, 0
- SBB ECX, [EAX+4]
- MOV [EDX+4], ECX
- end;
- {$ELSE cpu86} //Pascal
- function Neg64( const X: I64 ): I64;
- begin
- Int64(Result):=-Int64(X);
- end;
- {$ENDIF cpu86}
-
- {$IFDEF cpu86}
- //[function Mul64EDX]
- function Mul64EDX( const X: I64; M: Integer ): I64;
- asm
- PUSH ESI
- PUSH EDI
- XCHG ESI, EAX
- MOV EDI, ECX
- MOV ECX, EDX
- LODSD
- MUL ECX
- STOSD
- XCHG EDX, ECX
- LODSD
- MUL EDX
- ADD EAX, ECX
- STOSD
- POP EDI
- POP ESI
- end;
-
- //[FUNCTION Mul64i]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Mul64i( const X: I64; Mul: Integer ): I64;
- var Minus: Boolean;
- begin
- Minus := FALSE;
- if Mul < 0 then
- begin
- Minus := TRUE;
- Mul := -Mul;
- end;
- Result := Mul64EDX( X, Mul );
- if Minus then
- Result := Neg64( Result );
- end;
- {$ENDIF ASM_VERSION}
- {$ELSE cpu86}
- function Mul64i( const X: I64; Mul: Integer ): I64;
- begin
- Int64(Result):=Int64(X)*Mul;
- end;
- {$ENDIF cpu86}
- //[END Mul64i]
-
- {$IFDEF cpu86}
- //[function Div64EDX]
- function Div64EDX( const X: I64; D: Integer ): I64;
- asm
- PUSH ESI
- PUSH EDI
- XCHG ESI, EAX
- MOV EDI, ECX
- MOV ECX, EDX
- MOV EAX, [ESI+4]
- CDQ
- DIV ECX
- MOV [EDI+4], EAX
- LODSD
- DIV ECX
- STOSD
- POP EDI
- POP ESI
- end;
-
- //[FUNCTION Div64i]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Div64i( const X: I64; D: Integer ): I64;
- var Minus: Boolean;
- begin
- Minus := FALSE;
- if D < 0 then
- begin
- D := -D;
- Minus := TRUE;
- end;
- Result := X;
- if Sgn64( Result ) < 0 then
- begin
- Result := Neg64( Result );
- Minus := not Minus;
- end;
- Result := Div64EDX( Result, D );
- if Minus then
- Result := Neg64( Result );
- end;
- {$ENDIF ASM_VERSION}
- {$ELSE cpu86}
- function Div64i( const X: I64; D: Integer ): I64;
- begin
- Int64(Result):=Int64(X) div D;
- end;
- {$ENDIF cpu86}
- //[END Div64i]
-
- //[function Mod64i]
- function Mod64i( const X: I64; D: Integer ): Integer;
- begin
- Result := Sub64( X, Mul64i( Div64i( X, D ), D ) ).Lo;
- end;
-
- //[function Sgn64]
- {$IFDEF cpu86}
- function Sgn64( const X: I64 ): Integer;
- asm
- XOR EDX, EDX
- CMP [EAX+4], EDX
- XCHG EAX, EDX
- JG @@ret_1
- JL @@ret_neg
- CMP [EDX], EAX
- JZ @@exit
- @@ret_1:
- INC EAX
- RET
- @@ret_neg:
- DEC EAX
- @@exit:
- end;
- {$ELSE cpu86}
- function Sgn64( const X: I64 ): Integer;
- begin
- if Int64(X) > 0 then
- Result:=1
- else
- Result:=-1;
- end;
- {$ENDIF cpu86}
-
- //[function Cmp64]
- function Cmp64( const X, Y: I64 ): Integer;
- begin
- Result := Sgn64( Sub64( X, Y ) );
- end;
-
- //[function Int64_2Str]
- function Int64_2Str( X: I64 ): String;
- var M: Boolean;
- Y: Integer;
- Buf: array[ 0..31 ] of Char;
- I: Integer;
- begin
- M := FALSE;
- case Sgn64( X ) of
- -1: begin M := TRUE; X := Neg64( X ); end;
- 0: begin Result := '0'; Exit; end;
- end;
- I := 31;
- Buf[ 31 ] := #0;
- while Sgn64( X ) > 0 do
- begin
- Dec( I );
- Y := Mod64i( X, 10 );
- Buf[ I ] := Char( Y + Integer( '0' ) );
- X := Div64i( X, 10 );
- end;
- if M then
- begin
- Dec( I );
- Buf[ I ] := '-';
- end;
- Result := PChar( @Buf[ I ] );
- end;
-
- function Int64_2Hex( X: I64; MinDigits: Integer ): String;
- begin
- if (MinDigits <= 8) and (X.Hi <> 0) then
- Result := Int2Hex( X.Hi, 1 ) + Int2Hex( X.Lo, 8 )
- else if X.Hi <> 0 then
- Result := Int2Hex( X.Hi, MinDigits - 8 ) + Int2Hex( X.Lo, 8 )
- else
- Result := Int2Hex( X.Lo, MinDigits );
- end;
-
- //[function Str2Int64]
- function Str2Int64( const S: String ): I64;
- var I: Integer;
- M: Boolean;
- begin
- Result.Lo := 0;
- Result.Hi := 0;
- I := 1;
- if S = '' then Exit;
- M := FALSE;
- if S[ 1 ] = '-' then
- begin
- M := TRUE;
- Inc( I );
- end
- else
- if S[ 1 ] = '+' then
- Inc( I );
- while I <= Length( S ) do
- begin
- if not( S[ I ] in [ '0'..'9' ] ) then
- break;
- Result := Mul64i( Result, 10 );
- IncInt64( Result, Integer( S[ I ] ) - Integer( '0' ) );
- Inc( I );
- end;
- if M then
- Result := Neg64( Result );
- end;
-
- //[function Int64_2Double]
- {$IFDEF cpu86}
- function Int64_2Double( const X: I64 ): Double;
- asm
- FILD qword ptr [EAX]
- FSTP @Result
- end;
- {$ELSE cpu86}
- function Int64_2Double( const X: I64 ): Double;
- begin
- Result:=Int64(X);
- end;
- {$ENDIF cpu86}
-
- //[function Double2Int64]
- {$IFDEF cpu86}
- function Double2Int64( D: Double ): I64;
- asm
- FLD D
- FISTP qword ptr [EAX]
- end;
- {$ELSE cpu86}
- function Double2Int64( D: Double ): I64;
- begin
- Int64(Result):=Trunc(D);
- end;
- {$ENDIF cpu86}
-
- {+}
- function IsNan(const AValue: Double): Boolean;
- {$IFDEF _D2orD3}
- type PI64 = ^I64;
- {$ENDIF}
- begin
- {-}
- Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
- ((PI64(@AValue).Hi and $000FFFFF <> 0) or (PI64(@AValue).Lo <> 0));
- {+}{++}(*Result := AValue = NAN;*){--}
- end;
-
- function IsInfinity(const AValue: Double): Boolean;
- {$IFDEF _D2orD3}
- type PI64 = ^I64;
- {$ENDIF}
- begin
- {-}
- Result := (PI64(@AValue).Hi and $7FF00000 = $7FF00000) and
- (PI64(@AValue).Hi and $000FFFFF = $00000000);
- {+}{++}(*Result := AValue = Infinite;*){--}
- end;
-
- //[function IntPower]
- function IntPower(Base: Extended; Exponent: Integer): Extended;
- {$IFNDEF cpu86}
- begin
- {if Exponent = 0 then
- begin
- Result := 1.0;
- Exit;
- end;
- if Exponent < 0 then
- begin
- Exponent := -Exponent;
- Base := 1.0 / Base;
- end;
- Result := Base;
- REPEAT
- Result := Result * Base;
- Dec( Exponent );
- UNTIL Exponent <= 0;}
- Result := 1.0;
- if Exponent = 0 then exit;
- if Exponent < 0 then begin
- Exponent := -Exponent;
- Base := 1.0 / Base;
- end;
- REPEAT
- Result := Result * Base;
- Dec( Exponent );
- UNTIL Exponent=0;
- end;
- {$ELSE cpu86}
- // This version of code by Galkov:
- // Changes in comparison to Delphi standard:
- // no Overflow exception if Exponent is very big negative value
- // (just 0 in result in such case).
- asm
- fld1 { Result := 1 }
- test eax,eax // check Exponent for 0, return 0 ** 0 = 1
- jz @@3 // (though Mathematics says that this is not so...)
- fld Base
- jg @@2
- fdivr ST,ST(1) { Base := 1 / Base }
- neg eax
- jmp @@2
- @@1: fmul ST,ST { X := Base * Base }
- @@2: shr eax,1
- jnc @@1
- fmul ST(1),ST { Result := Result * X }
- jnz @@1
- fstp st { pop X from FPU stack }
- @@3: fwait
- end;
- {$ENDIF cpu86}
-
- //[function Str2Double]
- function Str2Double( const S: String ): Double;
- var I: Integer;
- M, Pt: Boolean;
- D: Double;
- Ex: Integer;
- begin
- Result := 0.0;
- if S = '' then Exit;
- M := FALSE;
- I := 1;
- if S[ 1 ] = '-' then
- begin
- M := TRUE;
- Inc( I );
- end;
- Pt := FALSE;
- D := 1.0;
- while I <= Length( S ) do
- begin
- case S[ I ] of
- '.': if not Pt then Pt := TRUE else break;
- '0'..'9': if not Pt then
- Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
- else
- begin
- D := D * 0.1;
- Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
- end;
- 'e', 'E': begin
- Ex := Str2Int( CopyEnd( S, I + 1 ) );
- Result := Result * IntPower( 10.0, Ex );
- break;
- end;
- end;
- Inc( I );
- end;
- if M then
- Result := -Result;
- end;
-
- function Str2Extended( const S: String ): Extended;
- var I: Integer;
- M, Pt: Boolean;
- D: Extended;
- Ex: Integer;
- begin
- Result := 0.0;
- if S = '' then Exit;
- M := FALSE;
- I := 1;
- if S[ 1 ] = '-' then
- begin
- M := TRUE;
- Inc( I );
- end;
- Pt := FALSE;
- D := 1.0;
- while I <= Length( S ) do
- begin
- case S[ I ] of
- '.': if not Pt then Pt := TRUE else break;
- '0'..'9': if not Pt then
- Result := Result * 10.0 + Integer( S[ I ] ) - Integer( '0' )
- else
- begin
- D := D * 0.1;
- Result := Result + (Integer( S[ I ] ) - Integer( '0' )) * D;
- end;
- 'e', 'E': begin
- Ex := Str2Int( CopyEnd( S, I + 1 ) );
- Result := Result * IntPower( 10.0, Ex );
- break;
- end;
- end;
- Inc( I );
- end;
- if M then
- Result := -Result;
- end;
-
- //[function TruncD]
- function TruncD( D: Double ): Double;
- {$ifdef cpu86}
- asm
- FLD D
- PUSH ECX
- FNSTCW [ESP]
- POP ECX
- PUSH ECX
- OR byte ptr [ESP+1], $0C
- FLDCW [ESP]
- PUSH ECX
- FRNDINT
- FSTP @Result
- FLDCW [ESP]
- POP ECX
- POP ECX
- end;
- {$else cpu86}
- begin
- Result := Trunc( D );
- end;
- {$endif cpu86}
-
- function IfThenElseBool( t, e: Boolean; Cond: Boolean ): Boolean;
- begin
- if cond then Result := t else Result := e;
- end;
- function IfThenElseInt( t, e: Integer; Cond: Boolean ): Integer;
- begin
- if cond then Result := t else Result := e;
- end;
- function IfThenElseStr( const t, e: String; Cond: Boolean ): String;
- begin
- if cond then Result := t else Result := e;
- end;
- {$IFDEF _D5orHigher}
- function IfThenElse( t, e: Boolean; Cond: Boolean ): Boolean; overload;
- begin
- if cond then Result := t else Result := e;
- end;
- function IfThenElse( t, e: Integer; Cond: Boolean ): Integer; overload;
- begin
- if cond then Result := t else Result := e;
- end;
- function IfThenElse( t, e: String; Cond: Boolean ): String; overload;
- begin
- if cond then Result := t else Result := e;
- end;
- function IfThenElse( t, e: Double; Cond: Boolean ): Double; overload;
- begin
- if cond then Result := t else Result := e;
- end;
- {$ENDIF}
-
-
- // Precision 15
- //[function Extended2Str]
- function Extended2Str( E: Extended ): String;
- function UnpackFromBuf( const Buf: array of Byte; N: Integer ): String;
- var I, J, K, L: Integer;
- begin
- SetLength( Result, 16 );
- J := 1;
- for I := 7 downto 0 do
- begin
- K := Buf[ I ] shr 4;
- Result[ J ] := Char( Ord('0') + K );
- Inc( J );
- K := Buf[ I ] and $F;
- Result[ J ] := Char( Ord('0') + K );
- Inc( J );
- end;
-
- Assert( Result[ 1 ] = '0', 'error!' );
- Delete( Result, 1, 1 );
-
- if N <= 0 then
- begin
- while N < 0 do
- begin
- Result := '0' + Result;
- Inc( N );
- end;
- Result := '0.' + Result;
- end
- else
- if N < Length( Result ) then
- begin
- Result := Copy( Result, 1, N ) + '.' + CopyEnd( Result, N + 1 );
- end
- else
- begin
- while N > Length( Result ) do
- begin
- Result := Result + '0';
- end;
- Exit;
- end;
-
- L := Length( Result );
- while L > 1 do
- begin
- if not (Result[ L ] in ['0','.']) then break;
- Dec( L );
- if Result[ L + 1 ] = '.' then break;
- end;
- if L < Length( Result ) then Delete( Result, L + 1, MaxInt );
-
- end;
-
- var
- S: Boolean;
- var F: Extended;
- N: Integer;
- Buf1: array[ 0..9 ] of Byte;
- I10: Integer;
- {$ifndef cpu86}
- procedure e2bcd(e:Extended);
- var
- i:byte;
- begin
- e:=e+0.5;
- for i := 0 to 9 do begin
- e:=Trunc(e)/10;
- Buf1[i]:=Trunc(frac(e)*10);
- e:=Trunc(e)/10;
- Buf1[i]:=(Trunc((frac(e)*10)) shl 4) or Buf1[i];
- end;
- end;
- {$endif cpu86}
- begin
- Result := '0';
- if E = 0 then Exit;
- S := E < 0;
- if S then E := -E;
-
- N := 15;
- F := 5E12;
- I10 := 10;
- while E < F do
- begin
- Dec( N );
- E := E * I10;
- end;
- if N = 15 then
- while E >= 1E13 do
- begin
- Inc( N );
- E := E / I10;
- end;
-
- while TRUE do
- begin
- {$ifdef cpu86}
- asm
- FLD [E]
- FBSTP [Buf1]
- end;
- {$else}
- e2bcd(E);
- {$endif cpu86}
- if Buf1[ 7 ] <> 0 then break;
- E := E * I10;
- Dec( N );
- end;
-
- Result := UnpackFromBuf( Buf1, N );
-
- if S then Result := '-' + Result;
- end;
-
- //[function Double2Str]
- function Double2Str( D: Double ): String;
- begin
- Result := Extended2Str( D );
- end;
-
- //[function Double2StrEx]
- function Double2StrEx( D: Double ): String;
- var E, E1, E2: Double;
- S: String;
- begin
- Result := Double2Str( D );
- E := Str2Double( Result );
- E1 := E - D;
- if E1 < 0.0 then E1 := -E1;
- if E1 < 1e-307 then Exit;
- while TRUE do
- begin
- E := D - (E - D) * 0.3;
- S := Double2Str( E );
- if S = Result then break;
- E := Str2Double( S );
- E2 := E - D;
- if E2 < 0.0 then E2 := -E2;
- if E2 > E1 * 0.75 then break;
- Result := S;
- if E2 < E1 * 0.1 then break;
- end;
- end;
-
- //[function GetBits]
- function GetBits( N: DWORD; first, last: Byte ): DWord;
- {$ifndef cpu86}
- begin
- Result := 0;
- if last > 31 then last := 31;
- if first > last then Exit;
- Result := (N and not ($FFFFFFFF shl last)) shr first;
- end;
- {$else}
- asm
- XCHG EAX, EDX // (1) EDX=N, AL=first
- {$IFDEF PARANOIA} DB $3C, 31 {$ELSE} CMP AL, 31 {$ENDIF} // first(AL) > 31 ?
- JBE @@1 // (2) åñëè äà, òî Result := 0;
- @@0:
- XOR EAX, EAX // (2)
- RET // (1)
- @@1:
-
- XCHG EAX, ECX // (1) AL = last CL = first
- SHR EDX, CL // (2) EDX = N shr first
- SUB AL, CL // (2) AL = last - first
- JL @@0 // (2) åñëè last < first òî Result := 0;
-
- {$IFDEF PARANOIA} DB $3C, 32 {$ELSE} CMP AL, 32 {$ENDIF} // (2) last - first >= 32 ?
- XCHG ECX, EAX // (1) CL = last - first
- XCHG EAX, EDX // (1) EAX = N shr first
- JAE @@exit // (2) åñëè last - first > 31, òî Result := EAX;
- SBB EDX, EDX // (2) EDX = -1
- DEC EDX // (1) EDX = 1111...10 = -2
- SHL EDX, CL // (2) EDX = 111...100..0 (ãäå n(0)=last-first+1)
- NOT EDX // (2) EDX = ìàñêà 000..0111...1 (ãäå n(1)=last-first+1)
- AND EAX, EDX // (2)
- @@exit:
- // EAX = ðåçóëüòàò, (1 áàéò íà êîìàíäó RET)
- end;
- {$endif cpu86}
-
- //[function GetBitsL]
- function GetBitsL( N: DWORD; from, len: Byte ): DWord;
- {$ifndef cpu86}
- begin
- Result := GetBits( N, from, from + len - 1 );
- end;
- {$else}
- asm
- ADD CL, DL
- DEC CL
- JMP GetBits
- end;
- {$endif cpu86}
-
- //[FUNCTION MulDiv]
- {$IFNDEF FPC}
- function MulDiv( A, B, C: Integer ): Integer;
- asm
- IMUL EDX
- IDIV ECX
- end;
- {$ENDIF}
- //[END MulDiv]
-
- //[FUNCTION Int2Hex]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal (mixed)
- function Int2Hex( Value : DWord; Digits : Integer ) : String;
- var Buf: array[ 0..8 ] of Char;
- Dest : PChar;
-
- function HexDigit( B : Byte ) : Char;
- {$ifdef FPC}
- const
- HexDigitChr: array[ 0..15 ] of Char = ( '0','1','2','3','4','5','6','7',
- '8','9','A','B','C','D','E','F' );
- begin
- Result := HexDigitChr[ B and $F ];
- end;
- {$else Delphi}
- asm
- {$IFDEF PARANOIA} DB $3C,9 {$ELSE} CMP AL,9 {$ENDIF}
- JA @@1
- {$IFDEF PARANOIA} DB $04, $30-$41+$0A {$ELSE} ADD AL,30h-41h+0Ah {$ENDIF}
- @@1:
- {$IFDEF PARANOIA} DB $04, $41-$0A {$ELSE} ADD AL,41h-0Ah {$ENDIF}
- end;
- {$endif FPC}
- begin
- Dest := @Buf[ 8 ];
- Dest^ := #0;
- repeat
- Dec( Dest );
- Dest^ := '0';
- if Value <> 0 then
- begin
- Dest^ := HexDigit( Value and $F );
- Value := Value shr 4;
- end;
- Dec( Digits );
- until (Value = 0) and (Digits <= 0);
- Result := Dest;
- end;
- {$ENDIF ASM_VERSION}
- //[END Int2Hex]
-
- //[FUNCTION Hex2Int]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Hex2Int( const Value : String) : Integer;
- var I : Integer;
- begin
- Result := 0;
- I := 1;
- if Value = '' then Exit;
- if Value[ 1 ] = '$' then Inc( I );
- while I <= Length( Value ) do
- begin
- if Value[ I ] in [ '0'..'9' ] then
- Result := (Result shl 4) or (Ord(Value[I]) - Ord('0'))
- else
- if Value[ I ] in [ 'A'..'F' ] then
- Result := (Result shl 4) or (Ord(Value[I]) - Ord('A') + 10)
- else
- if Value[ I ] in [ 'a'..'f' ] then
- Result := (Result shl 4) or (Ord(Value[I]) - Ord('a') + 10)
- else
- break;
- Inc( I );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END Hex2Int]
-
- //[FUNCTION Octal2Int]
- function Octal2Int( const Value: String ) : Integer;
- var I: Integer;
- begin
- Result := 0;
- for I := 1 to Length( Value ) do
- begin
- if Value[ I ] in [ '0'..'7' ] then
- Result := Result * 8 + Ord( Value[ I ] ) - Ord( '0' )
- else break;
- end;
- end;
- //[END Octal2Int]
-
- //[FUNCTION Binary2Int]
- function Binary2Int( const Value: String ) : Integer;
- var I: Integer;
- begin
- Result := 0;
- for I := 1 to Length( Value ) do
- begin
- if Value[ I ] in [ '0'..'1' ] then
- Result := Result * 2 + Ord( Value[ I ] ) - Ord( '0' )
- else break;
- end;
- end;
- //[END Binary2Int]
-
- //[FUNCTION cHex2Int]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function cHex2Int( const Value : String) : Integer;
- begin
- if StrEq( Copy( Value, 1, 2 ), '0x' ) then
- Result := Hex2Int( CopyEnd( Value, 3 ) )
- else Result := Hex2Int( Value );
- end;
- {$ENDIF ASM_VERSION}
- //[END cHex2Int]
-
- //[FUNCTION Int2Str]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Int2Str( Value : Integer ) : String;
- var Buf : array[ 0..15 ] of Char;
- Dst : PChar;
- Minus : Boolean;
- D: DWORD;
- begin
- Dst := @Buf[ 15 ];
- Dst^ := #0;
- Minus := False;
- if Value < 0 then
- begin
- Value := -Value;
- Minus := True;
- end;
- D := Value;
- repeat
- Dec( Dst );
- Dst^ := Char( (D mod 10) + Byte( '0' ) );
- D := D div 10;
- until D = 0;
- if Minus then
- begin
- Dec( Dst );
- Dst^ := '-';
- end;
- Result := Dst;
- end;
- {$ENDIF ASM_VERSION}
- //[END Int2Str]
-
- procedure Int2PChar( s: PChar; Value: Integer );
- var Buf : array[ 0..15 ] of Char;
- Dst : PChar;
- Minus : Boolean;
- D: DWORD;
- begin
- Dst := @Buf[ 15 ];
- Dst^ := #0;
- Minus := False;
- if Value < 0 then
- begin
- Value := -Value;
- Minus := True;
- end;
- D := Value;
- repeat
- Dec( Dst );
- Dst^ := Char( (D mod 10) + Byte( '0' ) );
- D := D div 10;
- until D = 0;
- if Minus then
- begin
- Dec( Dst );
- Dst^ := '-';
- end;
- StrCopy( s, Dst );
- end;
-
- //[function UInt2Str]
- function UInt2Str( Value: DWORD ): String;
- var Buf : array[ 0..15 ] of Char;
- Dst : PChar;
- D: DWORD;
- begin
- Dst := @Buf[ 15 ];
- Dst^ := #0;
- D := Value;
- repeat
- Dec( Dst );
- Dst^ := Char( (D mod 10) + Byte( '0' ) );
- D := D div 10;
- until D = 0;
- Result := Dst;
- end;
-
- //[function Int2StrEx]
- function Int2StrEx( Value, MinWidth: Integer ): String;
- begin
- Result := Int2Str( Value );
- while Length( Result ) < MinWidth do
- Result := ' ' + Result;
- end;
-
- //[function Int2Rome]
- function Int2Rome( Value: Integer ): String;
- const RomeDigs = 'IVXLCDMT';
- function RomeNum( N, FromIdx: Integer ): String;
- begin
- CASE N OF
- 1, 2, 3: Result := StrRepeat( RomeDigs[ FromIdx ], N );
- 4: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];
- 5, 6, 7, 8: Result := RomeDigs[ FromIdx + 1 ] + StrRepeat( RomeDigs[ FromIdx ],
- N - 5 );
- 9: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]
- else Result := '';
- END;
- end;
- var I, J: Integer;
- begin
- Result := '';
- if Value < 1 then Exit;
- if Value > 8999 then Exit;
- // maximum possible is TMMMCMXCIX, i.e. 8999
- J := 1;
- for I := 1 to 3 do
- begin
- Result := RomeNum( Value mod 10, J ) + Result;
- Value := Value div 10;
- if Value = 0 then Exit;
- Inc( J, 2 );
- end;
- end;
-
- //[FUNCTION Int2Ths]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Int2Ths( I : Integer ) : String;
- var S : String;
- begin
- S := Int2Str( I );
- Result := '';
- while S <> '' do
- begin
- if Result <> '' then
- Result := ThsSeparator + Result;
- Result := CopyTail( S, 3 ) + Result;
- S := Copy( S, 1, Length( S ) - 3 );
- end;
- if Copy( Result, 1, 2 ) = '-' + ThsSeparator then
- Result := '-' + CopyEnd( Result, 3 );
- end;
- {$ENDIF ASM_VERSION}
- //[END Int2Ths]
-
- //[FUNCTION Int2Digs]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Int2Digs( Value, Digits : Integer ) : String;
- var M : String;
- begin
- Result := Int2Str( Value );
- M := '';
- if Value < 0 then
- begin
- M := '-';
- Result := CopyEnd( Result, 2 );
- end;
- if Digits >= 0 then
- while Length( M + Result ) < Digits do
- Result := '0' + Result
- else
- while Length( Result ) < -Digits do
- Result := '0' + Result;
- Result := M + Result;
- end;
- {$ENDIF ASM_VERSION}
- //[END Int2Digs]
-
- //[FUNCTION Num2Bytes]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Num2Bytes( Value : Double ) : String;
- const Suffix = 'KMGT';
- var V, I : Integer;
- begin
- Result := '';
- I := 0;
- while (Value >= 1024) and (I < 4) do
- begin
- Inc( I );
- Value := Value / 1024.0;
- end;
- Result := Int2Str( Trunc( Value ) );
- V := Trunc( (Value - Trunc( Value )) * 100 );
- if V <> 0 then
- begin
- if (V mod 10) = 0 then
- V := V div 10;
- Result := Result + ',' + Int2Str( V );
- end;
- if I > 0 then
- Result := Result + Suffix[ I ];
- end;
- {$ENDIF ASM_VERSION}
- //[END Num2Bytes]
-
- //[FUNCTION S2Int]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function S2Int( S: PChar ): Integer;
- var M : Integer;
- begin
- Result := 0;
- if S = '' then Exit;
- M := 1;
- if S^ = '-' then
- begin
- M := -1;
- Inc( S );
- end
- else
- if S^ = '+' then
- Inc( S );
- while S^ in [ '0'..'9' ] do
- begin
- Result := Result * 10 + Integer( S^ ) - Integer( '0' );
- Inc( S );
- end;
- if M < 0 then
- Result := -Result;
- end;
- {$ENDIF ASM_VERSION}
- //[END S2Int]
-
- //[FUNCTION Str2Int]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Str2Int(const Value : String) : Integer;
- begin
- Result := S2Int( PChar( Value ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END Str2Int]
-
- //[function StrCopy]
- {$ifdef cpu86}
- function StrCopy( Dest, Source: PChar ): PChar; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Dest]
- MOV EDX, [Source]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- MOV ESI,EAX
- MOV EDI,EDX
- OR ECX, -1
- XOR AL,AL
- REPNE SCASB
- NOT ECX
- MOV EDI,ESI
- MOV ESI,EDX
- MOV EDX,ECX
- MOV EAX,EDI
- SHR ECX,2
- REP MOVSD
- MOV ECX,EDX
- AND ECX,3
- REP MOVSB
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$else}
- function StrCopy( Dest, Source: PChar ): PChar;
- var
- counter : SizeInt;
- Begin
- counter := 0;
- while Source[counter] <> #0 do
- begin
- Dest[counter] := char(Source[counter]);
- Inc(counter);
- end;
- Dest[counter] := #0;
- StrCopy := Dest;
- end;
- {$endif cpu86}
-
- function StrCat( Dest, Source: PChar ): PChar;
- begin
- StrCopy( StrScan( Dest, #0 ), Source );
- Result := Dest;
- end;
-
- //[function StrScan]
- {$ifdef cpu86}
- function StrScan(Str: PChar; Chr: Char): PChar; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- MOVZX EDX, [Chr]
- {$ENDIF}
- PUSH EDI
- PUSH EAX
- MOV EDI,Str
- OR ECX, -1
- XOR AL,AL
- REPNE SCASB
- NOT ECX
- POP EDI
- XCHG EAX, EDX
- REPNE SCASB
-
- XCHG EAX, EDI
- POP EDI
-
- JE @@1
- XOR EAX, EAX
- RET
-
- @@1: DEC EAX
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
-
- {$else}
-
- function StrScan(Str: PChar; Chr: Char): PChar;
- Begin
- repeat
- if Str^ = Chr then begin
- Result := Str;
- exit;
- end;
- Inc(Str);
- until Str^ = #0;
- StrScan := nil;
- end;
- {$endif cpu86}
-
- //[function StrRScan]
- {$ifdef cpu86}
- function StrRScan(const Str: PChar; Chr: Char): PChar; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- MOVZX EDX, [Chr]
- {$ENDIF F_P}
- PUSH EDI
- MOV EDI,Str
- MOV ECX,0FFFFFFFFH
- XOR AL,AL
- REPNE SCASB
- NOT ECX
- STD
- DEC EDI
- MOV AL,Chr
- REPNE SCASB
- MOV EAX,0
- JNE @@1
- MOV EAX,EDI
- INC EAX
- @@1: CLD
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
-
- {$else}
-
- function StrRScan(const Str: PChar; Chr: Char): PChar;
- Var
- count: longint;
- index: longint;
- Begin
- count := Strlen(Str);
- if Chr = #0 then
- begin
- StrRScan := @(Str[count]);
- exit;
- end;
- Dec(count);
- for index := count downto 0 do
- begin
- if Chr = Str[index] then
- begin
- StrRScan := @(Str[index]);
- exit;
- end;
- end;
- StrRScan := nil;
- end;
- {$endif cpu86}
-
- //[function StrScanLen]
- {$ifdef cpu86}
- function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- MOVZX EDX, [Chr]
- MOV ECX, [Len]
- {$ENDIF F_P}
- PUSH EDI
- XCHG EDI, EAX
- XCHG EAX, EDX
- REPNE SCASB
-
- XCHG EAX, EDI
- POP EDI
- { -> EAX => to next character after found or to the end of Str,
- ZF = 0 if character found. }
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
-
- {$else}
-
- function StrScanLen(Str: PChar; Chr: Char; Len: Integer): PChar;
- Begin
- Result:=Str;
- while Len > 0 do begin
- if Result^ = Chr then begin
- Inc(Result);
- break;
- end;
- Inc(Result);
- Dec(Len);
- end;
- end;
- {$endif cpu86}
-
- //[FUNCTION TrimLeft]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TrimLeft(const S: KOLstring): KOLstring;
- var
- I, L: Integer;
- begin
- L := Length(S);
- I := 1;
- while (I <= L) and (S[I] <= ' ') do Inc(I);
- Result := Copy(S, I, Maxint);
- end;
- {$ENDIF ASM_VERSION}
- //[END TrimLeft]
-
- //[FUNCTION TrimRight]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TrimRight(const S: KOLstring): KOLstring;
- var
- I: Integer;
- begin
- I := Length(S);
- while (I > 0) and (S[I] <= ' ') do Dec(I);
- Result := Copy(S, 1, I);
- end;
- {$ENDIF ASM_VERSION}
- //[END TrimRight]
-
- //[FUNCTION Trim]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function Trim( const S : KOLstring): KOLstring;
- begin
- Result := TrimLeft( TrimRight( S ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END Trim]
-
- //[function RemoveSpaces]
- function RemoveSpaces( const S: String ): String;
- var I: Integer;
- begin
- Result := S;
- for I := Length( S ) downto 1 do
- if S[ I ] <= ' ' then Delete( Result, I, 1 );
- end;
-
- //[procedure Str2LowerCase]
- {$ifdef cpu86}
- procedure Str2LowerCase( S: PChar );
- asm
- {$IFDEF F_P}
- MOV EAX, [S]
- {$ENDIF}
- XOR ECX, ECX
- @@1:
- MOV CL, byte ptr [EAX]
- JECXZ @@exit
- SUB CL, 'A'
- CMP CL, 'Z'-'A'
- JA @@2
- ADD byte ptr [EAX], 32
- @@2: INC EAX
- JMP @@1
- @@exit:
- end {$IFDEF F_P} [ 'EAX', 'ECX' ] {$ENDIF};
-
- {$else}
-
- procedure Str2LowerCase( S: PChar );
- begin
- while S^ <> #0 do begin
- if S^ in [ 'A'..'Z' ] then
- Inc( S^, 32 );
- Inc(S);
- end;
- end;
- {$endif cpu86}
-
- //[FUNCTION LowerCase]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function LowerCase(const S: string): string;
- var I : Integer;
- begin
- Result := S;
- for I := 1 to Length( S ) do
- if Result[ I ] in [ 'A'..'Z' ] then
- Inc( Result[ I ], 32 );
- end;
- {$ENDIF ASM_VERSION}
- //[END LowerCase]
-
- //[FUNCTION UpperCase]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function UpperCase(const S: string): string;
- var I : Integer;
- begin
- Result := S;
- for I := 1 to Length( S ) do
- if Result[ I ] in [ 'a'..'z' ] then
- Dec( Result[ I ], 32 );
- end;
- {$ENDIF ASM_VERSION}
- //[END UpperCase]
-
- {$IFDEF F_P}
- //[function DummyStrFun]
- function DummyStrFun( const S: String ): String;
- begin
- Result := S;
- end;
- {$ENDIF F_P}
-
- //[FUNCTION CopyEnd]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function CopyEnd( const S : KOLString; Idx : Integer ) : KOLString;
- begin
- Result := Copy( S, Idx, MaxInt );
- end;
- {$ENDIF ASM_VERSION}
- //[END CopyEnd]
-
- //[FUNCTION CopyTail]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function CopyTail( const S : KOLString; Len : Integer ) : KOLString;
- var L : Integer;
- begin
- L := Length( S );
- if L < Len then
- Len := L;
- Result := '';
- if Len = 0 then Exit;
- Result := Copy( S, L - Len + 1, Len );
- end;
- {$ENDIF ASM_VERSION}
- //[END CopyTail]
-
- //[PROCEDURE DeleteTail]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure DeleteTail( var S : KOLString; Len : Integer );
- var L : Integer;
- begin
- L := Length( S );
- if Len > L then
- Len := L;
- Delete( S, L - Len + 1, Len );
- end;
- {$ENDIF ASM_VERSION}
- //[END DeleteTail]
-
- //[FUNCTION IndexOfChar]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function IndexOfChar( const S : String; Chr : Char ) : Integer;
- var P, F : PChar;
- begin
- P := PChar( S );
- F := StrScan( P, Chr );
- Result := -1;
- if F = nil then Exit;
- Result := cardinal( F ) - cardinal( P ) + 1;
- end;
- {$ENDIF ASM_VERSION}
- //[END IndexOfChar]
-
- //[FUNCTION IndexOfCharsMin]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function IndexOfCharsMin( const S, Chars : String ) : Integer;
- var I, J : Integer;
- begin
- Result := -1;
- for I := 1 to Length( Chars ) do
- begin
- J := IndexOfChar( S, Chars[ I ] );
- if J > 0 then
- begin
- if (Result < 0) or (J < Result) then
- Result := J;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END IndexOfCharsMin]
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- //[function IndexOfWideCharsMin]
- function IndexOfWideCharsMin( const S, Chars : WideString ) : Integer;
- var I, J : Integer;
- begin
- Result := -1;
- for I := 1 to Length( Chars ) do
- begin
- J := pos( Chars[ I ], S );
- if J > 0 then
- begin
- if (Result < 0) or (J < Result) then
- Result := J;
- end;
- end;
- end;
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- //[FUNCTION IndexOfStr]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function IndexOfStr( const S, Sub : String ) : Integer;
- var I : Integer;
- begin
- Result := Length( S );
- if Sub = '' then Exit;
- Result := 0;
- if S = '' then Exit;
- if Length( Sub ) > Length( S ) then Exit;
- Result := 1;
- while Result + Length( Sub ) - 1 <= Length( S ) do
- begin
- I := IndexOfChar( CopyEnd( S, Result ), Sub[ 1 ] );
- if I <= 0 then break;
- Result := Result + I - 1;
- if Result <= 0 then Exit;
- if Copy( S, Result, Length( Sub ) ) = Sub then Exit;
- Inc( Result );
- end;
- Result := -1;
- end;
- {$ENDIF ASM_VERSION}
- //[END IndexOfStr]
-
- //[FUNCTION Parse]
- {$IFDEF ASM_UNICODE} //???
- function Parse( var S : String; const Separators : String ) : String;
- asm
- PUSH EBX
- PUSH EDI
- MOV EBX, EAX
-
- PUSH ECX
- MOV EAX, [EBX]
- CALL IndexOfCharsMin
- INC EAX
- JNE @@1
- MOV EAX, [EBX]
- CALL System.@LStrLen
- INC EAX
- INC EAX
- @@1:
- DEC EAX
- MOV EDI, EAX
- MOV ECX, EAX
- DEC ECX
- XOR EDX, EDX
- INC EDX
- MOV EAX, [EBX]
- CALL System.@LStrCopy
-
- MOV EAX, [EBX]
- MOV EDX, EDI
- INC EDX
- MOV ECX, EBX
- CALL CopyEnd
-
- POP EDI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function Parse( var S : KOLString; const Separators : KOLString ) : KOLString;
- var Pos : Integer;
- begin
- Pos := IndexOfCharsMin( S, Separators );
- if Pos <= 0 then
- Pos := Length( S ) + 1;
- Result := S;
- S := Copy( Result, Pos + 1, MaxInt );
- Result := Copy( Result, 1, Pos - 1 );
- end;
- {$ENDIF ASM_VERSION}
- //[END Parse]
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- //[function WParse]
- function WParse( var S : WideString; const Separators : WideString ) : WideString;
- var Pos : Integer;
- begin
- Pos := IndexOfWideCharsMin( S, Separators );
- if Pos <= 0 then
- Pos := Length( S ) + 1;
- Result := S;
- S := Copy( Result, Pos + 1, MaxInt );
- Result := Copy( Result, 1, Pos - 1 );
- end;
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- //[function ParsePascalString]
- function ParsePascalString( var S : String; const Separators : String ) : String;
- var Pos, Idx : Integer;
- Hex, Spc : boolean;
- procedure SkipSpaces;
- begin
- if not Spc then
- while (Length( S ) >= Pos) and (S[ Pos ] = ' ') do
- Inc( Pos );
- end;
- var Buf : String;
- Ou, Val : Integer;
- begin
- Pos := 1;
- Spc := IndexOfChar( Separators, ' ' ) >= 0;
- SkipSpaces;
- if Length( S ) < Pos then
- begin
- Result := S;
- S := '';
- exit;
- end;
- Buf := PChar( S );
- Ou := 1;
- if S[ Pos ] in [ '''', '#' ] then
- begin
- // skip here string constant expression
- while Pos <= Length( S ) do
- begin
- if S[ Pos ] = '''' then
- begin
- Inc( Pos );
- while Pos <= Length( S ) do
- begin
- if S[ Pos ] = '''' then
- if (Pos = Length( S )) or (S[ Pos+1 ] <> '''') then
- begin
- Inc( Pos );
- break;
- end
- else Inc( Pos );
- Buf[ Ou ] := S[ Pos ];
- Inc( Ou );
- Inc( Pos );
- end;
- end
- else
- if S[ Pos ] = '#' then
- begin
- Inc( Pos ); Hex := False; Val := 0;
- if (Pos < Length( S )) and (S[ Pos ] = '$') then
- begin
- Inc( Pos ); Hex := True;
- end;
- Dec( Pos );
- while Pos < Length( S ) do
- begin
- Inc( Pos );
- if (S[ Pos ] in [ '0'..'9' ]) or
- Hex and (S[ Pos ] in [ 'a'..'f', 'A'..'F' ]) then
- begin
- if Hex then
- Val := Val * 16
- else
- Val := Val * 10;
- if S[ Pos ] <= '9' then
- Val := Val + Integer( S[ Pos ] ) - Integer( '0' )
- else
- if S[ Pos ] <= 'F' then
- Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'A' )
- else
- Val := Val + 10 + Integer( S[ Pos ] ) - Integer( 'a' );
- continue;
- end;
- Inc( Pos ); break;
- end;
- Buf[ Ou ] := Char( Val );
- Inc( Ou );
- end
- else break;
- SkipSpaces;
- if S[ Pos ] <> '+' then break;
- SkipSpaces;
- end;
- end;
- Idx := IndexOfCharsMin( CopyEnd( S, Pos ), Separators );
- if Idx <= 0 then
- begin
- Result := Copy( Buf, 1, Ou - 1 ) + CopyEnd( S, Pos );
- S := '';
- end
- else
- begin
- Result := Copy( Buf, 1, Ou - 1 ) + Copy( S, Pos, Idx - 1 );
- S := CopyEnd( S, Pos + Idx );
- end;
- end;
-
- //[function String2PascalStrExpr]
- function String2PascalStrExpr( const S : String ) : String;
- var I, Strt : Integer;
- function String2DoubleQuotas( const S : String ) : String;
- var I, J : Integer;
- begin
- if IndexOfChar( S, '''' ) <= 0 then
- Result := S
- else
- begin
- J := 0;
- for I := 1 to Length( S ) do
- if S[ I ] = '''' then Inc( J );
- SetLength( Result, Length( S ) + J );
- J := 1;
- for I := 1 to Length( S ) do
- begin
- Result[ J ] := S[ I ];
- Inc( J );
- if S[ I ] = '''' then
- begin
- Result[ J ] := '''';
- Inc( J );
- end;
- end;
- end;
- end;
- begin
- Result := '';
- if S = '' then
- begin
- Result := '''''';
- exit;
- end;
- Strt := 1;
- for I := 1 to Length( S ) + 1 do
- begin
- if (I > Length( S )) or (S[ I ] < ' ') or (S[ I ] >= #$7F) then
- begin
- if (I > Strt) and (I > 1) then
- begin
- if Result <> '' then
- Result := Result + '+';
- Result := Result + '''' + String2DoubleQuotas( Copy( S, Strt, I - Strt ) ) + '''';
- end;
- if I > Length( S ) then break;
- if Result <> '' then
- Result := Result + '+'
- else
- Result := Result + '''''+';
- Result := Result + '#' + Int2Str( Integer( S[ I ] ) );
- Strt := I + 1;
- end;
- end;
- end;
-
- //[function CompareMem]
- {$ifdef cpu86}
- function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [P1]
- MOV EDX, [P2]
- MOV ECX, [Length]
- {$ENDIF}
- PUSH ESI
- PUSH EDI
- MOV ESI,P1
- MOV EDI,P2
- MOV EDX,ECX
- XOR EAX,EAX
- AND EDX,3
- SHR ECX,1
- SHR ECX,1
- REPE CMPSD
- JNE @@2
- MOV ECX,EDX
- REPE CMPSB
- JNE @@2
- @@1: INC EAX
- @@2: POP EDI
- POP ESI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
-
- {$else}
-
- function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
- var
- i: Integer;
- begin
- Result:=True;
- I:=0;
- If (P1)<>(P2) then
- While Result and (i<Length) do
- begin
- Result:=PByte(P1)^=PByte(P2)^;
- Inc(I);
- Inc(pchar(P1));
- Inc(pchar(P2));
- end;
- end;
- {$endif cpu86}
-
- //[FUNCTION AllocMem]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function AllocMem( Size : Integer ) : Pointer;
- begin
- Result := nil;
- if Size > 0 then
- begin
- GetMem( Result, Size );
- FillChar( Result^, Size, 0 );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END AllocMem]
-
- //[procedure DisposeMem]
- procedure DisposeMem( var Addr : Pointer );
- begin
- if Addr <> nil then
- FreeMem( Addr );
- Addr := nil;
- end;
-
- {$IFDEF WIN}
- //[function AnsiUpperCase]
- function AnsiUpperCase(const S: string): string;
- {$ifdef wince}
- begin
- Result:=WAnsiUpperCase(S);
- end;
- {$else}
- var Len: Integer;
- begin
- Len := Length(S);
- SetString(Result, PChar(S), Len);
- if Len > 0 then CharUpperBuffA(Pointer(Result), Len);
- end;
- {$endif wince}
-
- //[function AnsiLowerCase]
- function AnsiLowerCase(const S: string): string;
- {$ifdef wince}
- begin
- Result:=WAnsiLowerCase(S);
- end;
- {$else}
- var
- Len: Integer;
- begin
- Len := Length(S);
- SetString(Result, PChar(S), Len);
- if Len > 0 then CharLowerBuffA(Pointer(Result), Len);
- end;
- {$endif wince}
- {$ENDIF WIN}
-
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
-
- //[function WAnsiUpperCase]
- {$IFDEF WIN}
- function WAnsiUpperCase(const S: WideString): WideString;
- var Len: Integer;
- begin
- Result := S;
- Len := Length(S);
- if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
- end;
- {$ENDIF WIN}
-
- //[function WAnsiLowerCase]
- {$IFDEF WIN}
- function WAnsiLowerCase(const S: WideString): WideString;
- var Len: Integer;
- begin
- Result := S;
- Len := Length(S);
- if Len > 0 then CharLowerBuffW(Pointer(Result), Len);
- end;
- {$ENDIF WIN}
-
- {$IFDEF WIN}
- function WStrComp(const S1, S2: WideString): Integer;
- var i: Integer;
- begin
- for i := 1 to min( Length( S1 ), Length( S2 ) ) do
- begin
- Result := Ord( S1[ i ] ) - Ord( S2[ i ] );
- if Result <> 0 then Exit;
- end;
- Result := Length( S1 ) - Length( S2 );
- end;
-
- function _WStrComp(S1, S2: PWideChar): Integer;
- var Buf0: array[ 0..0 ] of WideChar;
- begin
- Buf0[ 0 ] := #0;
- if S1 = nil then S1 := @ Buf0[ 0 ];
- if S2 = nil then S2 := @ Buf0[ 0 ];
- while TRUE do
- begin
- Result := Ord( S1^ ) - Ord( S2^ );
- if Result <> 0 then Exit;
- if S1^ = #0 then Exit;
- end;
- end;
-
- function WStrScan(Str: PWideChar; Chr: WideChar): PWideChar;
- begin
- while (Str^ <> Chr) and (Str^ <> #0) do inc( Str );
- Result := Str;
- end;
-
- function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar;
- begin
- Result := Str;
- while Result^ <> #0 do inc( Result );
- while (DWORD( Result ) >= DWORD( Str )) and
- (Result^ <> Chr) do dec( Result );
- if (DWORD( Result ) < DWORD( Str )) then
- Result := nil;
- end;
- {$ENDIF WIN}
- {$ENDIF _FPC}
- {$ENDIF _D2}
-
- //[function AnsiCompareStr]
- {$IFDEF WIN}
- function AnsiCompareStr(const S1, S2: KOLString): Integer;
- begin
- Result := CompareString(LOCALE_USER_DEFAULT, 0, PKOLChar(S1), -1, PKOLChar(S2), -1 ) - 2;
- end;
- {$ENDIF WIN}
-
- //[function _AnsiCompareStr]
- {$IFDEF WIN}
- function _AnsiCompareStr(S1, S2: PKOLChar): Integer;
- begin
- Result := CompareString( LOCALE_USER_DEFAULT, 0, S1, -1,
- S2, -1) - 2;
- end;
- {$ENDIF WIN}
-
- //[function AnsiCompareStrNoCase]
- {$IFDEF WIN}
- function AnsiCompareStrNoCase(const S1, S2: KOLString): Integer;
- begin
- Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PKOLChar(S1), -1,
- PKOLChar(S2), -1 ) - 2;
- end;
- {$ENDIF WIN}
-
- //[function _AnsiCompareStrNoCase]
- {$IFDEF WIN}
- function _AnsiCompareStrNoCase(S1, S2: PKOLChar): Integer;
- begin
- Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,
- S2, -1) - 2;
- end;
- {$ENDIF WIN}
-
- //[function AnsiCompareText]
- function AnsiCompareText( const S1, S2: String ): Integer;
- begin
- Result := AnsiCompareStrNoCase( S1, S2 );
- end;
-
- //[function StrLCopy]
- {$IFDEF ASM_VERSION}
- function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Dest]
- MOV EDX, [Source]
- MOV ECX, [MaxLen]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- PUSH EBX
- MOV ESI,EAX
- MOV EDI,EDX
- MOV EBX,ECX
- XOR AL,AL
- TEST ECX,ECX
- JZ @@1
- REPNE SCASB
- JNE @@1
- INC ECX
- @@1: SUB EBX,ECX
- MOV EDI,ESI
- MOV ESI,EDX
- MOV EDX,EDI
- MOV ECX,EBX
- SHR ECX,2
- REP MOVSD
- MOV ECX,EBX
- AND ECX,3
- REP MOVSB
- STOSB
- MOV EAX,EDX
- POP EBX
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;
- var
- counter: cardinal;
- Begin
- counter := 0;
- { To be compatible with BP, on a null string, put two nulls }
- If Source[0] = #0 then
- Begin
- Dest[0]:=Source[0];
- Inc(counter);
- end;
- while (Source[counter] <> #0) and (counter < MaxLen) do
- Begin
- Dest[counter] := char(Source[counter]);
- Inc(counter);
- end;
- { terminate the string }
- Dest[counter] := #0;
- StrLCopy := Dest;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION StrPCopy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function StrPCopy(Dest: PChar; const Source: string): PChar;
- begin
- Result := StrLCopy(Dest, PChar(Source), Length(Source));
- end;
- {$ENDIF ASM_VERSION}
- //[END StrPCopy]
-
- //[FUNCTION StrEq]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function StrEq( const S1, S2 : String ) : Boolean;
- begin
- Result := (Length( S1 ) = Length( S2 )) and
- (LowerCase( S1 ) = LowerCase( S2 ));
- end;
- {$ENDIF ASM_VERSION}
- //[END StrEq]
-
- //[FUNCTION AnsiEq]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function AnsiEq( const S1, S2 : String ) : Boolean;
- begin
- Result := AnsiCompareStrNoCase( S1, S2 ) = 0;
- end;
- {$ENDIF ASM_VERSION}
- //[END AnsiEq]
-
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
- //[function WAnsiEq]
- function WAnsiEq( const S1, S2 : WideString ) : Boolean;
- begin
- Result := WAnsiLowerCase( S1 )=WAnsiLowerCase( S2 );
- end;
- {$ENDIF _FPC}
- {$ENDIF _D2}
-
- //[FUNCTION StrIn]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function StrIn(const S: String; const A: array of String): Boolean;
- var I : Integer;
- begin
- for I := Low( A ) to High( A ) do
- if StrEq( S, A[ I ] ) then
- begin
- Result := True;
- Exit;
- end;
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END StrIn]
-
- {$IFNDEF _D2}
- {$IFNDEF _FPC}
- //[function WStrIn]
- function WStrIn( const S : WideString; const A : array of WideString ) : Boolean;
- var I : Integer;
- begin
- for I := Low( A ) to High( A ) do
- if WAnsiEq( S, A[ I ] ) then
- begin
- Result := True;
- Exit;
- end;
- Result := False;
- end;
- {$ENDIF _FPC}
- {$ENDIF _D2}
-
- function CharIn( C: KOLChar; const A: TSetofChar ): Boolean;
- begin
- Result := (DWord( C ) <= 255) and (Char( C ) in A);
- end;
-
- //[function StrIs]
- function StrIs( const S : String; const A : array of String; var Idx: Integer ) : Boolean;
- var I : Integer;
- begin
- Idx := -1;
- for I := Low( A ) to High( A ) do
- if StrEq( S, A[ I ] ) then
- begin
- Idx := I;
- Result := True;
- Exit;
- end;
- Result := False;
- end;
-
- //[function IntIn]
- function IntIn( Value: Integer; const List: array of Integer ): Boolean;
- var I: Integer;
- begin
- Result := FALSE;
- for I := 0 to High( List ) do
- begin
- if Value = List[ I ] then
- begin
- Result := TRUE;
- break;
- end;
- end;
- end;
-
- //[FUNCTION _StrSatisfy]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function _StrSatisfy( S, Mask : PKOLChar ) : Boolean;
- label next_char;
- begin
- next_char:
- Result := True;
- if (S^ = #0) and (Mask^ = #0) then exit;
- if (Mask^ = '*') and (Mask[1] = #0) then exit;
- if S^ = #0 then
- begin
- while Mask^ = '*' do
- Inc( Mask );
- Result := Mask^ = #0;
- exit;
- end;
- Result := False;
- if Mask^ = #0 then exit;
- if Mask^ = '?' then
- begin
- Inc( S ); Inc( Mask ); goto next_char;
- end;
- if Mask^ = '*' then
- begin
- Inc( Mask );
- while S^ <> #0 do
- begin
- Result := _StrSatisfy( S, Mask );
- if Result then exit;
- Inc( S );
- end;
- exit; // (Result = False)
- end;
- Result := S^ = Mask^;
- Inc( S ); Inc( Mask );
- if Result then goto next_char;
- end;
- {$ENDIF ASM_VERSION}
- //[END _StrSatisfy]
-
- //[FUNCTION StrSatisfy]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function StrSatisfy( const S, Mask: KOLString ): Boolean;
- begin
- Result := _StrSatisfy( PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
- {$ELSE} AnsiLowerCase {$ENDIF} ( S ) ),
- PKOLChar( {$IFDEF UNICODE_CTRLS} WAnsiLowerCase
- {$ELSE} AnsiLowerCase {$ENDIF} ( Mask ) ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END StrSatisfy]
-
- //[FUNCTION _2StrSatisfy]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} // Pascal
- function _2StrSatisfy( S, Mask: PKOLChar ): Boolean;
- begin
- Result := StrSatisfy( S, Mask );
- end;
- {$ENDIF ASM_VERSION}
- //[END _2StrSatisfy]
-
- //[function StrReplace]
- function StrReplace( var S: String; const From, ReplTo: String ): Boolean;
- var I: Integer;
- begin
- I := pos( From, S );
- if I > 0 then
- begin
- S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
- Result := TRUE;
- end
- else Result := FALSE;
- end;
-
- function KOLStrReplace( var S: KOLString; const From, ReplTo: KOLString ): Boolean;
- var I: Integer;
- begin
- I := pos( From, S );
- if I > 0 then
- begin
- S := Copy( S, 1, I - 1 ) + ReplTo + CopyEnd( S, I + Length( From ) );
- Result := TRUE;
- end
- else Result := FALSE;
- end;
-
- {-}
- {$IFDEF _FPC}
- //[procedure SetLengthW]
- procedure SetLengthW( var W: WideString; NewLength: Integer );
- begin
- while Length( W ) < NewLength do
- W := W + ' ' + W;
- if Length( W ) > NewLength then
- Delete( W, NewLength + 1, Length( W ) - NewLength );
- end;
-
- //[function CopyW]
- function CopyW( const W: WideString; From, Count: Integer ): WideString;
- begin
- Result := '';
- if Count <= 0 then Exit;
- SetLengthW( Result, Count );
- Move( W[ From ], Result[ 1 ], Count * Sizeof( WideChar ) );
- end;
-
- //[function posW]
- function posW( const S1, S2: String ): Integer;
- var I, L1: Integer;
- begin
- L1 := Length( S1 );
- for I := 1 to Length( S2 )-L1+1 do
- begin
- if Copy( S2, I, L1 ) = S1 then
- begin
- Result := I;
- Exit;
- end;
- end;
- Result := 0;
- end;
- {$ENDIF _FPC}
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- //[function WStrReplace]
- function WStrReplace( var S: WideString; const From, ReplTo: WideString ): Boolean;
- var I: Integer;
- begin
- I := pos( From, S );
- if I > 0 then
- begin
- S := Copy( S, 1, I - 1 ) + ReplTo + Copy( S, I + Length( From ), MaxInt );
- Result := TRUE;
- end
- else Result := FALSE;
- end;
-
- //[function WStrRepeat]
- function WStrRepeat( const S: WideString; Count: Integer ): WideString;
- var I, L: Integer;
- begin
- L := Length( S );
- SetLength( Result, L * Count );
- for I := 0 to Count-1 do
- Move( S[ 1 ], Result[ 1 + I * L ], L * Sizeof( WideChar ) );
- end;
- {$ENDIF _D2}
- {$ENDIF _FPC}
-
- {+}
- //[function StrRepeat]
- function StrRepeat( const S: String; Count: Integer ): String;
- var I, L: Integer;
- begin
- L := Length( S );
- SetLength( Result, L * Count );
- for I := 0 to Count-1 do
- Move( S[ 1 ], Result[ 1 + I * L ], L );
- end;
-
- //[PROCEDURE NormalizeUnixText]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure NormalizeUnixText( var S: String );
- var I: Integer;
- begin
- if S <> '' then
- begin
- if S[ 1 ] = #10 then
- S[ 1 ] := #13;
- for I := 2 to Length(S) do
- if (S[I]=#10) and (S[I-1]<>#13) then
- S[I] := #13;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NormalizeUnixText]
-
- var Koi8_to_Ansi: array[ Char ] of Char;
- procedure Koi8ToAnsi( s: PChar );
- const KOI8_Rus: array[ #$C0..#$FF ] of Char = (
- #254,
- #224, #225, #246, #228, #229, #244, #227, #245, #232, #233, #234, #235, #235, #237, #238, #239,
- #255, #240, #241, #242, #243, #230, #226, #252, #251, #231, #248, #253, #249, #247, #250,
- #222,
- #192, #193, #214, #196, #197, #212, #195, #213, #200, #201, #202, #203, #204, #205, #206, #207,
- #223, #208, #209, #210, #211, #198, #194, #220, #219, #199, #216, #221, #217, #215, #218
- );
- var c: Char;
- begin
- if Koi8_to_Ansi[ #0 ] = #0 then
- begin
- for c := #1 to #255 do
- begin
- Koi8_to_Ansi[ c ] := c;
- if (c >= #$C0) and (c <= #$FF) then
- Koi8_to_Ansi[ c ] := KOI8_Rus[ c ];
- end;
- Koi8_to_Ansi[ #0 ] := #1;
- end;
- while s^ <> #0 do
- begin
- s^ := Koi8_to_Ansi[ s^ ];
- inc( s );
- end;
- end;
-
- //[function StrComp]
- {$IFDEF ASM_VERSION}
- function StrComp(const Str1, Str2: PChar): Integer; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str1]
- MOV EDX, [Str2]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- MOV EDI,EDX
- XCHG ESI,EAX
- OR ECX, -1
- XOR EAX,EAX
- REPNE SCASB
- NOT ECX
- MOV EDI,EDX
- XOR EDX,EDX
- REPE CMPSB
- MOV AL,[ESI-1]
- MOV DL,[EDI-1]
- SUB EAX,EDX
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrComp(const Str1, Str2 : PChar): Integer;
- var
- counter: Integer;
- Begin
- counter := 0;
- While str1[counter] = str2[counter] do
- Begin
- if (str2[counter] = #0) or (str1[counter] = #0) then
- break;
- Inc(counter);
- end;
- StrComp := ord(str1[counter]) - ord(str2[counter]);
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_VERSION}
- function StrComp_NoCase(const Str1, Str2: PChar): Integer;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str1]
- MOV EDX, [Str2]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- MOV EDI,EDX
- XCHG ESI,EAX
- OR ECX, -1
- XOR EAX,EAX
- REPNE SCASB
-
- NOT ECX
- MOV EDI,EDX
- @@0:
- XOR EDX,EDX
- REPE CMPSB
- MOV AL,[ESI-1]
- MOV AH, AL
- SUB AH, 'a'
- CMP AH, 25
- JA @@1
- SUB AL, $20
- @@1:
- MOV DL,[EDI-1]
- MOV AH, DL
- SUB AH, 'a'
- CMP AH, 25
- JA @@2
- SUB DL, $20
- @@2:
- MOV AH, 0
- SUB EAX,EDX
- JNZ @@exit
- CMP DL, 0
- JNZ @@0
-
- @@exit:
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrComp_NoCase(const Str1, Str2: PChar): Integer;
- var
- counter: Integer;
- Begin
- counter := 0;
- While UpCase(str1[counter]) = UpCase(str2[counter]) do
- Begin
- if (str2[counter] = #0) or (str1[counter] = #0) then
- break;
- Inc(counter);
- end;
- Result := ord(UpCase(str1[counter])) - ord(UpCase(str2[counter]));
- end;
- {$ENDIF ASM_VERSION}
-
- //[function StrLComp_NoCase]
- {$IFDEF ASM_VERSION}
- function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str1]
- MOV EDX, [Str2]
- MOV ECX, [MaxLen]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- PUSH EBX
- MOV EDI,EDX
- MOV ESI,EAX
- MOV EBX,ECX
- XOR EAX,EAX
- OR ECX,ECX
- JE @@exit
- REPNE SCASB
- SUB EBX,ECX
- MOV ECX,EBX
- MOV EDI,EDX
- @@0:
- XOR EDX,EDX
- REPE CMPSB
- MOV AL,[ESI-1]
- MOV AH, AL
- SUB AH, 'a'
- CMP AH, 25
- JA @@1
- SUB AL, $20
- @@1:
- MOV DL,[EDI-1]
- MOV AH, DL
- SUB AH, 'a'
- CMP AH, 25
- JA @@2
- SUB DL, $20
- @@2:
- MOV AH, 0
- SUB EAX,EDX
- JECXZ @@exit
- JZ @@0
-
- @@exit:
- POP EBX
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrLComp_NoCase(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
- var
- counter: cardinal;
- c1, c2: char;
- Begin
- counter := 0;
- if MaxLen = 0 then
- begin
- Result := 0;
- exit;
- end;
- Repeat
- c1 := UpCase(str1[counter]);
- c2 := UpCase(str2[counter]);
- if (c1 = #0) or (c2 = #0) then break;
- Inc(counter);
- Until (c1 <> c2) or (counter >= MaxLen);
- Result := ord(c1) - ord(c2);
- end;
- {$ENDIF ASM_VERSION}
-
- //[function StrLComp]
- {$IFDEF ASM_VERSION}
- function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str1]
- MOV EDX, [Str2]
- MOV ECX, [MaxLen]
- {$ENDIF F_P}
- PUSH EDI
- PUSH ESI
- PUSH EBX
- MOV EDI,EDX
- MOV ESI,EAX
- MOV EBX,ECX
- XOR EAX,EAX
- OR ECX,ECX
- JE @@1
- REPNE SCASB
- SUB EBX,ECX
- MOV ECX,EBX
- MOV EDI,EDX
- XOR EDX,EDX
- REPE CMPSB
- MOV AL,[ESI-1]
- MOV DL,[EDI-1]
- SUB EAX,EDX
- @@1: POP EBX
- POP ESI
- POP EDI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
- var
- counter: cardinal;
- c1, c2: char;
- Begin
- counter := 0;
- if MaxLen = 0 then
- begin
- StrLComp := 0;
- exit;
- end;
- Repeat
- c1 := str1[counter];
- c2 := str2[counter];
- if (c1 = #0) or (c2 = #0) then break;
- Inc(counter);
- Until (c1 <> c2) or (counter >= MaxLen);
- StrLComp := ord(c1) - ord(c2);
- end;
- {$ENDIF ASM_VERSION}
-
- //[function StrLen]
- {$IFDEF ASM_VERSION}
- function StrLen(const Str: PChar): Cardinal; assembler;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- {$ENDIF F_P}
- XCHG EAX, EDI
- XCHG EDX, EAX
- OR ECX, -1
- XOR EAX, EAX
- CMP EAX, EDI
- JE @@exit0
- REPNE SCASB
- DEC EAX
- DEC EAX
- SUB EAX,ECX
- @@exit0:
- MOV EDI,EDX
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrLen(const Str: PChar): Cardinal;
- var i : Cardinal;
- begin
- i:=0;
- while Str[i]<>#0 do inc(i);
- Result:=i;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION __DelimiterLast]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function __DelimiterLast( Str, Delimiters: PKOLChar ): PKOLChar;
- var
- P, F : PKOLChar;
- begin
- P := Str;
- Result := P + {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( Str );
- while Delimiters^ <> #0 do
- begin
- F := {$IFDEF UNICODE_CTRLS} WStrRScan {$ELSE} StrRScan {$ENDIF}
- ( P, Delimiters^ );
- if F <> nil then
- if (Result^ = #0) or (cardinal(F) > cardinal(Result)) then
- Result := F;
- Inc( Delimiters );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END __DelimiterLast]
-
- {$IFDEF _D3orHigher}
- function W__DelimiterLast( Str, Delimiters: PWideChar ): PWideChar;
- var
- P, F : PWideChar;
- begin
- P := Str;
- Result := P + WStrLen( Str );
- while Delimiters^ <> #0 do
- begin
- F := WStrRScan( P, Delimiters^ );
- if F <> nil then
- if (Result^ = #0) or (cardinal(F) > cardinal(Result)) then
- Result := F;
- Inc( Delimiters );
- end;
- end;
- {$ENDIF _D3orHigher}
-
- //[function SkipSpaces]
- function SkipSpaces( P: PKOLChar ): PKOLChar;
- begin
- while True do
- begin
- while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
- if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
- end;
- Result := P;
- end;
-
- //[function SkipParam]
- function SkipParam(P: PKOLChar): PKOLChar;
- begin
- P := SkipSpaces( P );
- while P[0] > ' ' do
- if P[0] = '"' then
- begin
- Inc(P);
- while (P[0] <> #0) and (P[0] <> '"') do
- Inc(P);
- if P[0] <> #0 then Inc(P);
- end
- else
- Inc(P);
- Result := P;
- end;
- {$IFDEF WIN}
-
- //[FUNCTION ParamStr]
- function ParamStr( Idx: Integer ): KOLString;
- var
- P, P1: PKOLChar;
- Buffer: array[ 0..260 ] of KOLChar;
- begin
- if Idx = 0 then
- SetString( Result, Buffer, GetModuleFileName( 0, Buffer, Sizeof( Buffer ) ) )
- else
- begin
- P := GetCommandLine;
- {$ifdef wince}
- Dec(Idx);
- {$endif}
- repeat
- P := SkipSpaces( P );
- P1 := P;
- P := SkipParam(P);
- if Idx = 0 then Break;
- Dec(Idx);
- until (Idx < 0) or (P = P1);
- Result := Copy( P1, 1, P - P1 );
- if Length( Result ) >= 2 then
- if (Result[ 1 ] = '"') and (Result[ Length( Result ) ] = '"') then
- Result := Copy( Result, 2, Length( Result ) - 2 );
- end;
- end;
- //[END ParamStr]
-
- //[FUNCTION ParamCount]
- function ParamCount: Integer;
- var
- S: string;
- begin
- Result := 0;
- while True do
- begin
- S := ParamStr(Result + 1);
- if S = '' then Break;
- Inc(Result);
- end;
- end;
- //[END ParamCount]
- {$ENDIF WIN}
-
- //[FUNCTION DelimiterLast]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function DelimiterLast( const Str, Delimiters: KOLString ): Integer;
- var PStr: PKOLChar;
- begin
- PStr := PKOLChar( Str );
- Result := cardinal( __DelimiterLast( PStr, PKOLChar( Delimiters ) ) )
- - cardinal( PStr )
- + {$IFDEF UNICODE_CTRLS} 2 {$ELSE} 1 {$ENDIF}; // {Viman}
- {$IFDEF UNICODE_CTRLS} Result := Result div SizeOf( WideChar ) {$ENDIF};
- end;
- {$ENDIF ASM_VERSION}
- //[END DelimiterLast]
-
- // Thanks to Marco Bobba - Marisa Bo for this code
- //[function StrIsStartingFrom]
- {$IFDEF ASM_UNICODE}
- function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- MOV EDX, [Pattern]
- {$ENDIF F_P}
- XOR ECX, ECX
- @@1:
- MOV CL, [EDX] // pattern[ i ]
- INC EDX
- MOV CH, [EAX] // str[ i ]
- INC EAX
- JECXZ @@2 // str = pattern; CL = #0, CH = #0
- CMP CL, CH
- JE @@1
- @@2:
- TEST CL, CL
- SETZ AL
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE}
- function StrIsStartingFrom( Str, Pattern: PKOLChar ): Boolean;
- begin
- Result := FALSE;
- while Pattern^ <> #0 do
- begin
- if Str^ <> Pattern^ then Exit;
- inc( Str );
- inc( Pattern );
- end;
- Result := TRUE;
- end;
- {$ENDIF ASM_UNICODE}
-
- {$IFDEF ASM_VERSION}
- function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
- asm
- {$IFDEF F_P}
- MOV EAX, [Str]
- MOV EDX, [Pattern]
- {$ENDIF F_P}
- XOR ECX, ECX
- @@1:
- MOV CL, [EDX] // pattern[ i ]
- INC EDX
- MOV CH, [EAX] // str[ i ]
- INC EAX
- JECXZ @@2 // str = pattern; CL = #0, CH = #0
- CMP CL, 'a'
- JB @@cl_ok
- CMP CL, 'z'
- JA @@cl_ok
- SUB CL, 32
- @@cl_ok:
- CMP CH, 'a'
- JB @@ch_ok
- CMP CH, 'z'
- JA @@ch_ok
- SUB CH, 32
- @@ch_ok:
- CMP CL, CH
- JE @@1
- @@2:
- TEST CL, CL
- SETZ AL
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION} //Pascal
- function StrIsStartingFromNoCase( Str, Pattern: PChar ): Boolean;
- begin
- Result := FALSE;
- while Pattern^ <> #0 do
- begin
- if UpCase(Str^) <> UpCase(Pattern^) then Exit;
- inc( Str );
- inc( Pattern );
- end;
- Result := TRUE;
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN}
- {$IFNDEF _FPC}
- //[FUNCTION Format]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function Format( const fmt: KOLString; params: array of const ): KOLString;
- var Buffer: array[ 0..2047 ] of KOLChar;
- ElsArray, El: ^pointer;
- I : Integer;
- begin
- ElsArray := nil;
- if High( params ) >= 0 then
- GetMem( ElsArray, (High( params ) + 1) * sizeof( Pointer ) );
- El := ElsArray;
- for I := 0 to High( params ) do
- begin
- El^ := params[ I ].VPointer;
- Inc( El );
- end;
- wvsprintf( @Buffer[0], PKOLChar( fmt ), PChar( ElsArray ) );
- Result := Buffer;
- if ElsArray <> nil then
- FreeMem( ElsArray );
- end;
- {$ENDIF ASM_VERSION}
- //[END Format]
- {$ENDIF WIN}
-
- //[function LStrFromPWCharLen]
- function LStrFromPWCharLen(Source: PWideChar; Length: Integer): String;
- var
- DestLen: Integer;
- Buffer: array[0..2047] of Char;
- begin
- if Length <= 0 then
- begin
- Result := '';
- Exit;
- end;
- if Length < SizeOf(Buffer) div 2 then
- begin
- DestLen := WideCharToMultiByte(0, 0, Source, Length,
- Buffer, SizeOf(Buffer), nil, nil);
- if DestLen > 0 then
- begin
- Result := Buffer;
- Exit;
- end;
- end;
- DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
- // _LStrFromPCharLen(Dest, nil, DestLen);
- SetLength( Result, DestLen );
- WideCharToMultiByte(0, 0, Source, Length, Pointer(Result), DestLen, nil, nil);
- end;
-
- //[function LStrFromPWChar]
- {$IFDEF ASM_VERSION}
- function LStrFromPWChar(Source: PWideChar): String;
- {* from Delphi5 - because D2 does not contain it. }
- asm
- PUSH EDX
- XOR EDX,EDX
- TEST EAX,EAX
- JE @@5
- PUSH EAX
- @@0: CMP DX,[EAX+0]
- JE @@4
- CMP DX,[EAX+2]
- JE @@3
- CMP DX,[EAX+4]
- JE @@2
- CMP DX,[EAX+6]
- JE @@1
- ADD EAX,8
- JMP @@0
- @@1: ADD EAX,2
- @@2: ADD EAX,2
- @@3: ADD EAX,2
- @@4: XCHG EDX,EAX
- POP EAX
- SUB EDX,EAX
- SHR EDX,1
- @@5: POP ECX
- JMP LStrFromPWCharLen
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ELSE ASM_VERSION}
- function LStrFromPWChar(Source: PWideChar): String;
- begin
- Result:=Source;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF _FPC}
-
- /////////////////////////////////////////////////////////////////////////
- //
- //
- // F I L E S
- //
- //
- /////////////////////////////////////////////////////////////////////////
- //[FILES]
- {
- This part of the unit modified by Tim Slusher and Vladimir Kladov.
- }
-
- {* Set of utility methods to work with files
- and reqistry.
- When programming KOL, which is Windows API-oriented, You should
- avoid alien (for Windows) embedded Pascal files handling, and
- use API-calls which implemented very well. This set of functions
- is intended to make this easier.
- Also TDirList object implementation present here and some registry
- access functions, which allow to make code more elegant.
- }
-
- {$UNDEF ASM_LOCAL}
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_LOCAL}
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION FileCreate]
- {$IFDEF WIN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileCreate(const FileName: KOLString; OpenFlags: DWord): THandle;
- var Attr: DWORD;
- begin
- Attr := (OpenFlags shr 16) and $1FFF;
- if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
- Result := CreateFile( PKOLChar(FileName), OpenFlags and $F0000000,
- OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
- Attr, 0 );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileCreate]
-
- {$IFDEF _D3orHigher}
- function WFileCreate(const FileName: WideString; OpenFlags: DWord): THandle;
- var Attr: DWORD;
- begin
- Attr := (OpenFlags shr 16) and $1FFF;
- if Attr = 0 then Attr := FILE_ATTRIBUTE_NORMAL;
- Result := CreateFileW( PWideChar(FileName), OpenFlags and $F0000000,
- OpenFlags and $F, nil, (OpenFlags shr 8) and $F,
- Attr, 0 );
- end;
- {$ENDIF _D3orHigher}
-
- //[FUNCTION FileClose]
- {$IFDEF WIN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileClose(Handle: THandle): boolean;
- begin
- Result := CloseHandle(Handle);
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileClose]
-
- {$UNDEF ASM_LOCAL}
- {$IFDEF ASM_UNICODE}
- {$DEFINE ASM_LOCAL}
- {$ENDIF}
- {$IFDEF FILE_EXISTS_EX}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
-
- //[FUNCTION FileExists]
- {$IFDEF WIN}
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- function FileExists( const FileName : KOLString ) : Boolean;
- {$IFDEF FILE_EXISTS_EX}
- var FD: TFindFileData;
- //F: DWORD;
- LFT: TFileTime;
- Hi, Lo: Word;
- {$ELSE}
- var Code: Integer;
- {$ENDIF}
- begin
- {$IFDEF FILE_EXISTS_EX}
- Result := FALSE;
- if not Find_First( Filename, FD ) then Exit;
- Find_Close( FD );
- if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
- FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
- if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
- {$ELSE}
- Code := GetFileAttributes(PKOLChar(FileName));
- Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileExists]
-
- {$IFDEF _D3orHigher}
- function WFileExists( const FileName: WideString ) : Boolean;
- {$IFDEF notimplemented_FILE_EXISTS_EX}
- var FD: TFindFileData;
- //F: DWORD;
- LFT: TFileTime;
- Hi, Lo: Word;
- {$ELSE}
- var Code: Integer;
- {$ENDIF}
- begin
- {$IFDEF notimplemented_FILE_EXISTS_EX}
- Result := FALSE;
- if not WFind_First( Filename, FD ) then Exit;
- WFind_Close( FD );
- if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
- FileTimeToLocalFileTime( FD.ftLastWriteTime, LFT );
- if FileTimeToDosDateTime( LFT, Hi, Lo ) then Result := TRUE;
- {$ELSE}
- Code := GetFileAttributesW(PWideChar(FileName));
- Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
- {$ENDIF}
- end;
- {$ENDIF _D3orHigher}
-
- //[FUNCTION FileSeek]
- {$IFDEF WIN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileSeek(Handle: THandle; MoveTo: integer; MoveMethod: TMoveMethod): DWord;
- begin
- Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileSeek]
-
- {$IFDEF _D4orHigher}
- {$IFDEF WIN}
- function FileFarSeek(Handle: THandle; MoveTo: Int64; MoveMethod: TMoveMethod): DWord;
- begin
- Result := SetFilePointer(Handle, MoveTo, nil, Ord( MoveMethod ) );
- end;
- {$ENDIF WIN}
- {$ENDIF _D4orHigher}
-
- //[FUNCTION FileRead]
- {$IFDEF WIN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileRead(Handle: THandle; var Buffer; Count: DWord): DWord;
- begin
- if not ReadFile(Handle, Buffer, Count, Result, nil) then
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileRead]
-
- //[FUNCTION File2Str]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function File2Str(Handle: THandle): String;
- var Pos, Size: DWORD;
- begin
- Result := '';
- if Handle = 0 then Exit;
- Pos := FileSeek( Handle, 0, spCurrent );
- Size := GetFileSize( Handle, nil );
- SetString( Result, nil, Size - Pos + 1 );
- FileRead( Handle, Result[ 1 ], Size - Pos );
- Result[ Size - Pos + 1 ] := #0;
- end;
- {$ENDIF ASM_VERSION}
- //[END File2Str]
-
- {$IFNDEF _D2}
- function File2WStr(Handle: THandle): WideString;
- var Pos, Size: DWORD;
- begin
- Result := '';
- if Handle = 0 then Exit;
- Pos := FileSeek( Handle, 0, spCurrent );
- Size := GetFileSize( Handle, nil );
- SetString( Result, nil, (Size - Pos + 1)*Sizeof( WideChar ) );
- FileRead( Handle, Result[ 1 ], Size - Pos );
- Result[ Size - Pos + 1 ] := #0;
- end;
- {$ENDIF _D2}
-
- //[FUNCTION FileWrite]
- {$IFDEF WIN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileWrite(Handle: THandle; const Buffer; Count: DWord): DWord;
- begin
- if not WriteFile(Handle, Buffer, Count, Result, nil) then
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileWrite]
-
- //[FUNCTION FileEOF]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function FileEOF( Handle: THandle ) : Boolean;
- var Siz, Pos : DWord;
- begin
- Siz := GetFileSize( Handle, nil );
- Pos := FileSeek( Handle, 0, spCurrent );
- Result := Pos >= Siz;
- end;
- {$ENDIF ASM_VERSION}
- //[END FileEOF]
-
- //[FUNCTION FileFullPath]
- {$IFDEF WIN}
- {$IFDEF ASM_noVERSION_UNICODE}
- function FileFullPath( const FileName: String ) : String;
- const
- BkSlash: String = '\';
- szTShFileInfo = sizeof( TShFileInfo );
- asm
- PUSH EBX
- PUSH ESI
- MOV EBX, EDX
- PUSH EAX
-
- XCHG EAX, EDX
- CALL System.@LStrClr
-
- POP EDX
- PUSH 0
- MOV EAX, ESP
- CALL System.@LStrAsg
- MOV ESI, ESP
-
- @@loo: CMP dword ptr [ESI], 0
- JZ @@fin
-
- MOV EAX, ESI
- MOV EDX, [BkSlash]
- PUSH 0
- MOV ECX, ESP
- CALL Parse
-
- CMP dword ptr [EBX], 0
- JE @@1
- MOV EAX, EBX
- MOV EDX, [BkSlash]
- CALL System.@LStrCat
- JMP @@2
- @@1:
- POP EAX
- PUSH EAX
- CALL System.@LStrLen
- CMP EAX, 2
- JNE @@2
- POP EAX
- PUSH EAX
- CMP byte ptr [EAX+1], ':'
- JNE @@2
-
- MOV EAX, EBX
- POP EDX
- PUSH EDX
- CALL System.@LStrAsg
- JMP @@3
- @@2:
- PUSH 0
- MOV EAX, ESP
- MOV EDX, [EBX]
- CALL System.@LStrAsg
- MOV EAX, ESP
- MOV EDX, [ESP+4]
- CALL System.@LStrCat
- POP EAX
- PUSH EAX
- SUB ESP, szTShFileInfo
- MOV EDX, ESP
- PUSH SHGFI_DISPLAYNAME
- PUSH szTShFileInfo
- PUSH EDX
- PUSH 0
- PUSH EAX
- CALL ShGetFileInfo
- LEA EDX, [ESP].TShFileInfo.szDisplayName
- CMP byte ptr [EDX], 0
- JE @@clr_stk
- LEA EAX, [ESP+szTShFileInfo+4]
- CALL System.@LStrFromPChar
- @@clr_stk:
- ADD ESP, szTShFileInfo
- CALL RemoveStr
- POP EDX
- PUSH EDX
- MOV EAX, EBX
- CALL System.@LStrCat
-
- @@3: CALL RemoveStr
- JMP @@loo
-
- @@fin: CALL RemoveStr
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function FileFullPath( const FileName: KOLString ) : KOLString;
- var SFI: TShFileInfo;
- Src, S: KOLString;
- begin
- Result := '';
- Src := FileName;
- while Src <> '' do
- begin
- S := Parse( Src, '\' );
- if Result <> '' then
- Result := Result + '\';
- if (Result = '') and (Length( S ) = 2) and (S[ 2 ] = ':') then
- Result := S
- else
- begin
- {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
- ( PKOLChar( Result + S ), 0, SFI, Sizeof( SFI ), SHGFI_DISPLAYNAME );
- if SFI.szDisplayName[ 0 ] <> #0 then
- S := SFI.szDisplayName;
- Result := Result + S;
- end;
- end;
- if ExtractFileExt( Result ) = '' then
- // case when flag 'Hide extensions for registered file types' is set on
- // in the Explorer:
- Result := Result + ExtractFileExt( FileName );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
- //[END FileFullPath]
-
- {$IFDEF WIN}
- //[function FileShortPath]
- function FileShortPath( const FileName: KOLString ): KOLString;
- {$ifdef wince}
- begin
- Result:=FileName;
- end;
- {$else wince}
- var Buf: array[ 0..MAX_PATH ] of KOLChar;
- begin
- GetShortPathName( PKOLChar( FileName ), Buf, Sizeof( Buf ) );
- Result := Buf;
- end;
- {$endif wince}
-
- //[function FileIconSystemIdx]
- function FileIconSystemIdx( const Path: KOLString ): Integer;
- var SFI: TShFileInfo;
- begin
- SFI.iIcon := 0; // Bartov
- {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
- ( PKOLChar( Path ), 0, SFI, sizeof( SFI ), SHGFI_SMALLICON or SHGFI_SYSICONINDEX );
- Result := SFI.iIcon;
- end;
-
- //[function FileIconSysIdxOffline]
- function FileIconSysIdxOffline( const Path: KOLString ): Integer;
- var SFI: TShFileInfo;
- begin
- SFI.iIcon := 0; // Bartov
- {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
- ( PKOLChar( Path ), FILE_ATTRIBUTE_NORMAL, SFI, sizeof( SFI ),
- SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
- Result := SFI.iIcon;
- end;
- {$ENDIF WIN}
-
- //[procedure LogFileOutput]
- procedure LogFileOutput( const filepath, str: String );
- var F: THandle;
- Tmp: String;
- begin
- F := FileCreate( filepath, ofOpenWrite or ofOpenAlways or ofShareDenyWrite );
- if F = INVALID_HANDLE_VALUE then Exit;
- FileSeek( F, 0, spEnd );
- Tmp := str + {$IFDEF LIN} #10 {$ELSE} #13#10 {$ENDIF};
- FileWrite( F, PChar( Tmp )^, Length( Tmp ) );
- FileClose( F );
- end;
-
- //[function StrLoadFromFile]
- function StrLoadFromFile( const Filename: KOLString ): String;
- var F: THandle;
- begin
- {$IFDEF WIN32}
- if StrEq( Filename, 'CON' ) then
- Result := File2Str(GetStdHandle(STD_INPUT_HANDLE))
- else
- {$ENDIF WIN32}
- begin
- Result := '';
- F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
- if F = INVALID_HANDLE_VALUE then Exit;
- Result := File2Str( F );
- FileClose( F ); {Dark Knight}
- end;
- end;
-
- //[function StrSaveToFile]
- function StrSaveToFile( const Filename: KOLString; const Str: String ): Boolean;
- begin
- Result := Mem2File( PKOLChar( Filename ), PChar( Str ), Length( Str ) )
- = Length( Str );
- end;
-
- {$IFNDEF _D2}
- function WStrLoadFromFile( const Filename: KOLString ): WideString;
- var F: THandle;
- begin
- {$IFDEF WIN32}
- if StrEq( Filename, 'CON' ) then
- Result := File2WStr(GetStdHandle(STD_INPUT_HANDLE))
- else
- {$ENDIF WIN32}
- begin
- Result := '';
- F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
- if F = INVALID_HANDLE_VALUE then Exit;
- Result := File2Str( F );
- FileClose( F ); {Dark Knight}
- end;
- end;
-
- function WStrSaveToFile( const Filename: KOLString; const Str: WideString ): Boolean;
- begin
- Result := Mem2File( PKOLChar( Filename ), PWideChar( Str ), Length( Str ) )
- = Length( Str );
- end;
- {$ENDIF _D2}
-
-
- //[function Mem2File]
- function Mem2File( Filename: PKOLChar; Mem: Pointer; Len: Integer ): Integer;
- var F: THandle;
- begin
- Result := 0;
- F := FileCreate( Filename, ofOpenWrite or ofCreateAlways );
- if F = INVALID_HANDLE_VALUE then Exit;
- Result := FileWrite( F, Mem^, Len );
- FileClose( F );
- end;
-
- //[function File2Mem]
- function File2Mem( Filename: PKOLChar; Mem: Pointer; MaxLen: Integer ): Integer;
- var F: THandle;
- begin
- Result := 0;
- F := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyWrite );
- if F = INVALID_HANDLE_VALUE then Exit;
- Result := FileRead( F, Mem^, MaxLen );
- FileClose( F );
- end;
-
- {$IFDEF WIN}
- function Find_First( const FilePathName: KOLString; var F: TFindFileData ): Boolean;
- begin
- F.FindHandle := FindFirstFile( PKOLChar( FilePathName ),
- {$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF}
- ( @ F )^ );
- Result := F.FindHandle <> INVALID_HANDLE_VALUE;
- end;
- function Find_Next( var F: TFindFileData ): Boolean;
- begin
- Result := FindNextFile( F.FindHandle,
- {$IFDEF UNICODE_CTRLS} PWin32FindDataW {$ELSE} PWin32FindData {$ENDIF}
- ( @ F )^ );
- end;
- procedure Find_Close( var F: TFindFileData );
- begin
- Windows.FindClose( F.FindHandle );
- end;
- {$ENDIF WIN}
-
- //[FUNCTION FileSize]
- {$IFDEF WIN}
- function FileSize( const Path: KOLString ) : {$IFDEF _D2orD3} Integer {$ELSE} Int64 {$ENDIF};
- var FD : TFindFileData;
- begin
- Result := 0;
- if not Find_First( Path, FD ) then exit;
- {$IFDEF _D2orD3}
- Result := FD.nFileSizeLow;
- {$ELSE}
- I64( Result ).Lo := FD.nFileSizeLow;
- I64( Result ).Hi := FD.nFileSizeHigh;
- {$ENDIF}
- Find_Close( FD );
- end;
- {$ENDIF WIN}
- //[END FileSize]
-
- //[procedure FileTime]
- procedure FileTime( const Path: KOLString;
- CreateTime, LastAccessTime, LastModifyTime: PFileTime );
- var FD : TFindFileData;
- begin
- if not Find_First( Path, FD ) then exit;
- if CreateTime <> nil then
- CreateTime^ := FD.ftCreationTime;
- if LastAccessTime <> nil then
- LastAccessTime^ := FD.ftLastAccessTime;
- if LastModifyTime <> nil then
- LastModifyTime^ := FD.ftLastWriteTime;
- Find_Close( FD );
- end;
-
- //[function GetUniqueFilename]
- function GetUniqueFilename( PathName: KOLstring ) : KOLString;
- var Path, Nam, Ext : KOLString;
- I, J, K : Integer;
- begin
- Result := PathName;
- Path := ExtractFilePath( PathName );
- if not DirectoryExists( Path ) then Exit;
- Nam := ExtractFileNameWOext( PathName );
- if Nam = '' then
- begin
- Path := ExcludeTrailingPathDelimiter( Path );
- PathName := Path;
- Result := Path;
- end;
- Nam := ExtractFileNameWOext( PathName );
- Ext := ExtractFileExt( PathName );
- I := Length( Nam );
- for J := I downto 1 do
- if not ((Nam[ J ] >= '0') and (Nam[ J ] <= '9')) then
- begin
- I := J;
- break;
- end;
- K := Str2Int( CopyEnd( Nam, I + 1 ) );
- while FileExists( Result ) do
- begin
- Inc( K );
- Result := Path + Copy( Nam, 1, I ) + Int2Str( K ) + Ext;
- end;
- end;
-
- {$IFDEF WIN}
- //[FUNCTION CompareSystemTime]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CompareSystemTime(const D1, D2 : TSystemTime) : Integer;
- var R: Integer;
- procedure CompareFields(const F1, F2 : Integer);
- begin
- if R <> 0 then Exit;
- if F1 = F2 then Exit;
- if F1 < F2 then
- R := -1
- else
- R := 1;
- end;
- begin
- R := 0;
- CompareFields( D1.wYear, D2.wYear );
- CompareFields( D1.wMonth, D2.wMonth );
- CompareFields( D1.wDay, D2.wDay );
- CompareFields( D1.wHour, D2.wHour );
- CompareFields( D1.wMinute, D2.wMinute );
- CompareFields( D1.wSecond, D2.wSecond );
- CompareFields( D1.wMilliseconds, D2.wMilliseconds );
- Result := R;
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareSystemTime]
-
- //[function FileTimeCompare]
- function FileTimeCompare( const FT1, FT2 : TFileTime ) : Integer;
- var ST1, ST2 : TSystemTime;
- begin
- FileTimeToSystemTime( FT1, ST1 );
- FileTimeToSystemTime( FT2, ST2 );
- Result := CompareSystemTime( ST1, ST2 );
- end;
- {$ENDIF WIN}
-
- {$IFDEF WIN}
- //[FUNCTION DirectoryExists]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function DirectoryExists(const Name: KOLString): Boolean;
- var
- Code: Integer;
- {$ifndef wince}
- e: DWORD;
- {$endif wince}
- begin
- {$ifndef wince}
- e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
- {$endif wince}
- Code := GetFileAttributes(PKOLChar(Name));
- Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
- {$ifndef wince}
- SetErrorMode( e );
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- //[END DirectoryExists]
-
- function DiskPresent( const DrivePath: KOLString ): Boolean;
- {$ifndef wince}
- var e: DWORD;
- restore: Boolean;
- {$endif wince}
- begin
- {$ifndef wince}
- e := 0;
- Restore := FALSE;
- if (Copy( DrivePath, 1, 2 ) = '\\') then
- else
- CASE GetDriveType( PKOLChar( DrivePath ) ) OF
- DRIVE_REMOVABLE, DRIVE_CDROM, DRIVE_RAMDISK:
- begin
- e := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
- Restore := TRUE;
- end;
- END;
- {$endif wince}
- Result := DirectoryExists( DrivePath );
- {$ifndef wince}
- if Restore then
- SetErrorMode( e );
- {$endif wince}
- end;
-
- {$IFDEF _D3orHigher}
- function WDirectoryExists(const Name: WideString): Boolean;
- var
- Code: Integer;
- begin
- Code := GetFileAttributesW(PWideChar(Name));
- Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
- end;
- {$ENDIF _D3orHigher}
-
- {$ENDIF WIN}
-
- //[function CheckDirectoryContent]
- function CheckDirectoryContent( const Name: KOLString; SubDirsOnly: Boolean; const Mask: String ): Boolean;
- var FD: TFindFileData;
- begin
- if not DirectoryExists( Name ) then
- Result := TRUE
- else
- begin
- if not Find_First( IncludeTrailingPathDelimiter( Name ) + Mask, FD ) then
- Result := TRUE
- else
- begin
- Result := TRUE;
- repeat
- if not {$IFDEF UNICODE_CTRLS}WStrIn{$ELSE}StrIn{$ENDIF}( FD.cFileName, ['.','..'] ) then
- begin
- if SubDirsOnly and LongBool(FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)
- or not SubDirsOnly then
- begin
- Result := FALSE;
- break;
- end;
- end;
- until not Find_Next( FD );
- Find_Close( FD );
- end;
- end;
- end;
-
- //[function DirectoryEmpty]
- function DirectoryEmpty(const Name: KOLString): Boolean;
- begin
- Result := CheckDirectoryContent( Name, FALSE, '*.*' );
- end;
-
- //[function DirectoryHasSubdirs]
- function DirectoryHasSubdirs( const Path: KOLString ): Boolean;
- begin
- Result := not CheckDirectoryContent( Path, TRUE, '*.*' );
- end;
-
- //[FUNCTION GetStartDir]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- {$IFDEF WIN}
- {$UNDEF LINUX_USE_HOME_STARTFDIR}
- {$ENDIF}
- function GetStartDir : KOLString;
- {$IFNDEF LINUX_USE_HOME_STARTFDIR}
- var Buffer:array[0..MAX_PATH] of KOLChar;
- I : Integer;
- {$ENDIF}
- begin
- {$IFDEF LINUX_USE_HOME_STARTFDIR}
- Result := getenv( 'HOME' );
- {$ELSE}
- I := GetModuleFileName( 0, Buffer, MAX_PATH );
- for I := I downto 0 do
- if Buffer[ I ] = {$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF} then
- begin
- Buffer[ I + 1 ] := #0;
- break;
- end;
- Result := Buffer;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END GetStartDir]
-
- //[FUNCTION ExePath]
- function ExePath: KOLString;
- var Buffer: array[ 0..MAX_PATH+1 ] of KOLChar;
- begin
- Buffer[ MAX_PATH+1 ] := #0;
- GetModuleFileName( hInstance, Buffer, MAX_PATH+1 );
- Result := Buffer;
- end;
-
- {-}
- //[function DirectorySize]
- function DirectorySize( const Path: KOLString ): I64;
- var DirList: PDirList;
- I: Integer;
- begin
- Result := MakeInt64( 0, 0 );
- DirList := NewDirList( Path, {$IFDEF LIN} '*' {$ELSE} '*.*' {$ENDIF}, 0 );
- for I := 0 to DirList.Count-1 do
- begin
- if LongBool( DirList.Items[ I ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY ) then
- Result := Add64( Result, DirectorySize( DirList.Path + DirList.Names[ I ] ) )
- else
- Result := Add64( Result, MakeInt64( DirList.Items[ I ].nFileSizeLow,
- DirList.Items[ I ].nFileSizeHigh ) );
- end;
- DirList.Free;
- end;
- {+}
-
- {$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[function GetFileList]
- function GetFileList(const dir: string): PStrList;
- var
- Srch: TFindFileData;
- succ: boolean;
- begin
- result := nil;
- succ := Find_First(dir, Srch);
- while succ do begin
- if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
- if Result = nil then begin
- Result := NewStrList;
- end;
- Result.Add(Srch.cFileName);
- end;
- succ := Find_Next(Srch);
- end;
- Find_Close(Srch);
- end;
-
- {$ENDIF WIN}
- //[function ExcludeTrailingChar]
- function ExcludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
- begin
- Result := S;
- if Result <> '' then
- if Result[ Length( Result ) ] = C then
- Delete( Result, Length( Result ), 1 );
- end;
-
- //[function IncludeTrailingChar]
- {$IFDEF ASM_UNICODE}
- function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
- asm
- push edx
- push ecx
- xchg ecx, eax
- xchg edx, ecx
- call System.@LStrAsg
- pop eax
- pop edx
- mov ecx, [eax]
- jecxz @@1
- add ecx, [ecx-4]
- dec ecx
- cmp byte ptr [ecx], dl
- jz @@exit
- @@1:
- push eax
- push 0
- mov eax, esp
- call System.@LStrFromChar
- mov edx, [esp]
- mov eax, [esp+4]
- call System.@LStrCat
- call RemoveStr
- pop eax
- @@exit:
- end;
- {$ELSE PASCAL}
- function IncludeTrailingChar( const S: KOLString; C: KOLChar ): KOLString;
- begin
- Result := S;
- if (Result = '') or (Result[ Length( Result ) ] <> C) then
- Result := Result + C;
- end;
- {$ENDIF ASM_VERSION}
-
-
- //---------------------------------------------------------
- // Following functions/procedures are created by Edward Aretino:
- // IncludeTrailingPathDelimiter, ExcludeTrailingPathDelimiter,
- // ForceDirectories, CreateDir, ChangeFileExt
- //---------------------------------------------------------
- //[function IncludeTrailingPathDelimiter]
- function IncludeTrailingPathDelimiter(const S: KOLstring): KOLstring;
- begin
- Result := IncludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
- end;
-
- //[function ExcludeTrailingPathDelimiter]
- function ExcludeTrailingPathDelimiter(const S: KOLstring): KOLstring;
- begin
- Result := ExcludeTrailingChar( S, {$IFDEF UNIX} '/' {$ELSE} '\' {$ENDIF} );
- end;
-
- function ExtractFileDrive( const Path: KOLString ) : KOLString;
- var i, j: Integer;
- begin
- Result := Path;
- if Result = '' then Exit;
- if pos( ':', Result ) > 1 then
- Result := Parse( Result, ':' ) + ':\'
- else
- if Length( Result ) > 2 then
- begin
- j := 0;
- for i := 3 to Length( Result ) do
- if Result[ i ] = '\' then
- begin
- inc( j );
- if j = 2 then
- begin
- Result := Copy( Result, 1, i );
- break;
- end;
- end;
- Result := IncludeTrailingPathDelimiter( Result );
- end
- else
- if Length( Result ) = 1 then
- Result := Result + ':\';
- end;
-
- //[FUNCTION ExtractFilePath]
- {$IFDEF ASM_LStrFromPCharLen} // LStrFromPCharLen - there are no in D2
- function ExtractFilePath( const Path : String ) : String;
- asm
- PUSH EDX
- MOV EDX, [DirDelimiters]
- CALL EAX2PChar
- PUSH EAX
- CALL __DelimiterLast
- XCHG EDX, EAX
- XOR ECX, ECX
- POP EAX
- CMP byte ptr [EDX], CL
- JZ @@ret_0
- SUB EDX, EAX
- INC EDX
- XCHG EDX, EAX
- XCHG ECX, EAX
- @@ret_0:
- POP EAX
- CALL System.@LStrFromPCharLen
- end;
- {$ELSE} //Pascal
- function ExtractFilePath( const Path : KOLString ) : KOLString;
- //var I : Integer;
- var P, P0: PKOLChar;
- begin
- P0 := PKOLChar( Path );
- P := __DelimiterLast( P0, ':\/' );
- if P^ = #0 then
- Result := ''
- else
- Result := Copy( Path, 1, P - P0 + 1 );
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF _D3orHigher}
- function WExtractFilePath( const Path: WideString ) : WideString;
- var P, P0: PWideChar;
- begin
- P0 := PWideChar( Path );
- P := W__DelimiterLast( P0, ':\/' );
- if P^ = #0 then
- Result := ''
- else
- Result := Copy( Path, 1, P - P0 + 1 );
- end;
- {$ENDIF}
-
- {$IFDEF ASM_VERSION}
- {$IFNDEF _D2}
- {$DEFINE ASM_LStrFromPCharLen}
- {$ENDIF}
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_LStrFromPCharLen}
- {$DEFINE ASM_DIRDelimiters}
- {$ENDIF}
-
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_DIRDelimiters}
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_DIRDelimiters}
- const
- DirDelimiters: PChar = ':\/';
- {$ENDIF}
-
- function IsNetworkPath( const Path: KOLString ): Boolean;
- begin
- Result := (Length( Path ) >= 2) and (Path[1] = '\') and (Path[2] = '\');
- end;
-
- //[FUNCTION ExtractFileName]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function ExtractFileName( const Path : KOLString ) : KOLString;
- var P: PKOLChar;
- begin
- P := __DelimiterLast( PKOLChar( Path ), ':\/' );
- if P^ = #0 then
- Result := Path
- else
- Result := P + 1;
- end;
- {$ENDIF ASM_VERSION}
- //[END ExtractFileName]
-
- //[function ExtractFileNameWOext]
- {$IFDEF ASM_UNICODE}
- function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
- asm
- push ebx
-
- push edx
- push eax
- call ExtractFileName
- pop edx // Path - íå íóæåí áîëüøå
- mov eax, [esp] // eax = Result = ExtractFileName(Path)
- mov eax, [eax]
- push 0
- mov edx, esp
- call ExtractFileExt
- mov eax, [esp]
- call System.@LStrLen
- xchg ebx, eax // ebx = Length(ExtractFileExt(Result))
- call RemoveStr // ExtractFileExt - áîëüøå íå íóæåí
- mov eax, [esp]
- mov eax, [eax]
- call System.@LStrLen // eax = Length(Result)
- sub eax, ebx
- xchg ecx, eax
- xor edx, edx
- inc edx
- mov eax, [esp]
- mov eax, [eax]
- call System.@LStrCopy
-
- pop ebx
- end;
- {$ELSE PASCAL}
- function ExtractFileNameWOext( const Path : KOLString ) : KOLString;
- begin
- Result := ExtractFileName( Path );
- Result := Copy( Result, 1, Length( Result ) - Length( ExtractFileExt( Result ) ) );
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_UNICODE}
- const
- ExtDelimeters: PChar = '.';
-
- //[function ExtractFileExt]
- function ExtractFileExt( const Path : KOLString ) : KOLString;
- asm
- PUSH EDX
- MOV EDX, [ExtDelimeters]
- CALL EAX2PChar
- CALL __DelimiterLast
- @@1: XCHG EDX, EAX
- POP EAX
- CALL System.@LStrFromPChar
- end;
- {$ELSE ASM_VERSION} //Pascal
- function ExtractFileExt( const Path : KOLString ) : KOLString;
- var P: PKOLChar;
- begin
- P := __DelimiterLast( PKOLChar( Path ), '.' );
- Result := P;
- end;
- {$ENDIF ASM_VERSION}
- //[END ExtractFilePath]
-
- //[function ReplaceExt]
- {$IFDEF ASM_UNICODE}
- function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
- asm
- push ecx // result
- push edx // NewExt
- push eax // Path
-
- push 0
- mov edx, esp
- call ExtractFilePath
- pop eax
- xchg [esp], eax // eax=Path, Path in stack replaced with ExtractFilePath(Path)
-
- push 0
- mov edx, esp
- call ExtractFileNameWOext
- // now stack conatins: result,NewExt,ExtractFilePath(Path),ExtractFileNameWOext(Path)<-ESP
-
- mov eax, [esp+12]
- mov edx, esp
- push dword ptr [edx+4] // ExtractFilePath(Path)
- push dword ptr [edx] // ExtractFileNameWOext(Path)
- push dword ptr [edx+8] // NewExt
- mov edx, 3
- call System.@LStrCatN
- call RemoveStr
- call RemoveStr
- pop ecx
- pop ecx
- end;
- {$ELSE PASCAL}
- function ReplaceExt( const Path, NewExt: KOLString ): KOLString;
- begin
- Result := ExtractFilePath( Path ) + ExtractFileNameWOext( Path ) +
- NewExt;
- end;
- {$ENDIF}
-
- //[function ForceDirectories]
- function ForceDirectories(Dir: KOLString): Boolean;
- begin
- Result := Length(Dir) > 0; {Centronix}
- If not Result then Exit;
- Dir := ExcludeTrailingPathDelimiter(Dir);
- If (Length(Dir) < 3) or DirectoryExists(Dir) or
- (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
- Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
- end;
-
- //[function CreateDir]
- function CreateDir(const Dir: KOLString): Boolean;
- begin
- Result := {$IFDEF WIN} {Windows.}CreateDirectory(PKOLChar(Dir), nil)
- {$ELSE LIN} Libc.__mkdir(PChar(Dir), S_IRWXU or S_IRWXG or S_IRWXO) = 0
- {$ENDIF};
- end;
-
- //[function ChangeFileExt]
- function ChangeFileExt(FileName: KOLString; const Extension: KOLstring): KOLstring;
- var
- FileExt: KOLString;
- begin
- FileExt := ExtractFileExt(FileName);
- DeleteTail(FileName, Length(FileExt));
- Result := FileName+ Extension;
- end;
-
- //[function ReplaceFileExt]
- function ReplaceFileExt( const Path, NewExt: KOLString ): KOLString;
- begin
- Result := ExtractFilePath( Path ) +
- ExtractFileNameWOext( ExtractFileName( Path ) ) +
- NewExt;
- end;
-
- {$IFDEF WIN} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //[function ExtractShortPathName]
- function ExtractShortPathName( const Path: KOLString ): KOLString;
- {$ifdef wince}
- begin
- Result:=Path;
- {$else}
- var
- Buffer: array[0..MAX_PATH - 1] of KOLChar;
- begin
- SetString(Result, Buffer,
- GetShortPathName(PKOLChar(Path), Buffer, SizeOf(Buffer) div Sizeof(KOLChar)));
- {$endif wince}
- end;
-
- {$IFDEF GDI}
- //[function FilePathShortened]
- function FilePathShortened( const Path: KOLString; MaxLen: Integer ): KOLString;
- begin
- Result := FilePathShortenPixels( Path, 0, MaxLen );
- end;
-
- //[function PixelsLength]
- function PixelsLength( DC: HDC; const Text: KOLString ): Integer;
- var Sz: TSize;
- begin
- if DC = 0 then
- Result := Length( Text )
- else
- begin
- {Windows.}GetTextExtentPoint32( DC, PKOLChar( Text ), Length( Text ), Sz );
- Result := Sz.cx;
- end;
- end;
-
- //[function FilePathShortenPixels]
- function FilePathShortenPixels( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
- var L0, L1: Integer;
- Prev: KOLString;
- begin
- Result := Path;
- L0 := PixelsLength( DC, Result );
- while L0 > MaxPixels do
- begin
- Prev := Result;
- L1 := pos( '\...\', Result );
- if L1 <= 0 then
- Result := ExcludeTrailingPathDelimiter( ExtractFilePath( Result ) )
- else
- Result := Copy( Result, 1, L1 - 1 );
- if Result <> '' then
- Result := IncludeTrailingPathDelimiter( ExtractFilePath( Result ) ) + '...\' + ExtractFileName( Path );
- if (Result = '') or (Result = Prev) then
- begin
- L1 := Length( ExtractFilePath( Result ) );
- while (PixelsLength( DC, Result ) > MaxPixels) and (L1 > 1) do
- begin
- Dec( L1 );
- Result := Copy( Result, 1, L1 ) + '...\' + ExtractFileName( Result );
- end;
- if PixelsLength( DC, Result ) > MaxPixels then
- begin
- L1 := MaxPixels + 1;
- while ((MaxPixels > 0) and (L1 > 1) or (MaxPixels = 0) and (L1 > 0)) and
- (PixelsLength( DC, Result ) > MaxPixels) do
- begin
- Dec( L1 );
- Result := Copy( ExtractFileName( Path ), 1, L1 ) + '...';
- end;
- end;
- break;
- end;
- L0 := PixelsLength( DC, Result );
- end;
- end;
- {$ENDIF GDI}
-
- //[procedure CutFirstDirectory]
- procedure CutFirstDirectory(var S: KOLString);
- var
- Root: Boolean;
- P: Integer;
- begin
- if S = '\' then
- S := ''
- else
- begin
- if S[1] = '\' then
- begin
- Root := True;
- Delete(S, 1, 1);
- end
- else
- Root := False;
- if S[1] = '.' then
- Delete(S, 1, 4);
- P := pos('\',S);
- if P <> 0 then
- begin
- Delete(S, 1, P);
- S := '...\' + S;
- end
- else
- S := '';
- if Root then
- S := '\' + S;
- end;
- end;
-
- {$IFDEF GDI}
- //[function MinimizeName]
- function MinimizeName( const Path: KOLString; DC: HDC; MaxPixels: Integer ): KOLString;
- var
- Drive, Dir, Name: KOLString;
- begin
- Result := Path;
- Dir := ExtractFilePath(Result);
- Name := ExtractFileName(Result);
-
- if (Length(Dir) >= 2) and (Dir[2] = ':') then
- begin
- Drive := Copy(Dir, 1, 2);
- Delete(Dir, 1, 2);
- end
- else
- Drive := '';
- while ((Dir <> '') or (Drive <> '')) and (PixelsLength(DC, Result) > MaxPixels) do
- begin
- if Dir = '\...\' then
- begin
- Drive := '';
- Dir := '...\';
- end
- else if Dir = '' then
- Drive := ''
- else
- CutFirstDirectory(Dir);
- Result := Drive + Dir + Name;
- end;
- end;
- {$ENDIF GDI}
-
- //[function GetSystemDir]
- function GetSystemDir: KOLString;
- {$ifdef wince}
- begin
- Result:=GetWindowsDir;
- {$else}
- var Buf: array[ 0..MAX_PATH ] of KOLChar;
- begin
- GetSystemDirectory( @ Buf[ 0 ], MAX_PATH + 1 );
- Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
- {$endif wince}
- end;
-
- //*
- //[function GetWindowsDir]
- function GetWindowsDir : KOLstring;
- {$ifdef wince}
- var
- wPath : array[0..MAX_PATH] of WideChar;
- begin
- if SHGetSpecialFolderPath(0, wPath, $0024{CSIDL_WINDOWS}, False) then
- Result:=IncludeTrailingPathDelimiter(wPath)
- else
- Result:='';
- {$else}
- var Buf : array[ 0..MAX_PATH ] of KOLChar;
- begin
- GetWindowsDirectory( @Buf[ 0 ], MAX_PATH + 1 );
- Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
- {$endif wince}
- end;
- {$ENDIF WIN} //^^^^^^^^^^^
-
- //[function GetWorkDir]
- {$IFDEF WIN}
- function GetWorkDir : KOLstring;
- {$ifdef wince}
- begin
- Result:='\';
- {$else}
- var Buf: array[ 0..MAX_PATH ] of Char;
- begin
- GetCurrentDirectory( MAX_PATH + 1, @ Buf[ 0 ] );
- Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
- {$endif wince}
- end;
- {$ENDIF WIN}
-
- //[function GetTempDir]
- {$IFDEF ASM_UNICODE}
- function GetTempDir : KOLstring;
- asm
- push eax
- sub esp, 264
- push esp
- push 261
- call GetTempPath
- mov edx, esp
- mov eax, [esp+264]
- call System.@LStrFromPChar
- add esp, 264
- pop edx
- mov eax, [edx]
- call IncludeTrailingPathDelimiter
- end;
- {$ELSE PASCAL}
- function GetTempDir : KOLstring;
- {$IFDEF WIN} var Buf : array[ 0..MAX_PATH ] of KOLChar; {$ENDIF WIN}
- begin
- {$IFDEF LIN} Result := '/tmp/'; {$ELSE WIN}
- GetTempPath( MAX_PATH + 1, @Buf[ 0 ] );
- Result := IncludeTrailingPathDelimiter( PKOLChar( @ Buf[ 0 ] ) );
- {$ENDIF WIN}
- end;
- {$ENDIF}
-
- {$IFDEF WIN}
- //[function CreateTempFile]
- {$IFDEF ASM_UNICODE}
- function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
- asm
- push ecx
- call EAX2PCHAR
- call EDX2PCHAR
- sub esp, 264
- push esp
- push 0
- push edx
- push eax
- call GetTempFileName
- mov eax, [esp+264]
- mov edx, esp
- call System.@LStrFromPChar
- add esp, 268
- end;
- {$ELSE PASCAL}
- function CreateTempFile( const DirPath, Prefix: KOLString ): KOLString;
- var Buf: array[ 0..MAX_PATH ] of KOLChar;
- begin
- GetTempFileName( PKOLChar( DirPath ), PKOLChar( Prefix ), 0, Buf );
- Result := Buf;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN}
-
- //[function GetFileListStr]
- function GetFileListStr(FPath{e.g.'c:\tmp\'}, FMask{e.g.'*.*'}: KOLstring): KOLstring;
- {* List of files in string, separating each path from others with FileOpSeparator.
- E.g.: 'c:\tmp\unit1.dcu'#13'c:\tmp\unit1.~pa' (for use with DeleteFile2Recycle())}
- var
- Srch: TFindFileData;
- succ: boolean;
- dir:KOLstring;
- begin
- result := '';
- if (FPath<>'') then FPath := IncludeTrailingPathDelimiter( FPath );
- if (FMask<>'') and (FMask[1]={$IFDEF LIN} '/' {$ELSE} '\' {$ENDIF}) then
- FMask := CopyEnd(FMask,2);
- dir:=FPath+FMask;
- succ := Find_First(dir, Srch);
- while succ do begin
- if (not (Srch.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0))then begin
- if Result<>''then Result:=Result+FileOpSeparator;
- Result:=Result+FPath+Srch.cFileName;
- end;
- succ := Find_Next(Srch);
- end;
- Find_Close(Srch);
- end;
-
- //[function DeleteFiles]
- function DeleteFiles( const DirPath: KOLString ): Boolean;
- var Files, Name: KOLString;
- begin
- Files := GetFileListStr( ExtractFilePath( DirPath ), ExtractFileName( DirPath ) );
- Result := TRUE;
- while Files <> '' do
- begin
- Name := Parse( Files, FileOpSeparator );
- Result := Result and DeleteFile( PKOLChar( Name ) );
- end;
- end;
-
- {$IFDEF WIN_GDI} //>>>>>>>>>>>>
- //[function DeleteFile2Recycle]
- function DeleteFile2Recycle( const Filename : KOLString ) : Boolean;
- begin
- Result := DoFileOp( Filename, '', FO_DELETE, FOF_ALLOWUNDO or
- FOF_NOCONFIRMATION or FOF_SIMPLEPROGRESS, 'Deleting...' );
- end;
-
- //[function CopyMoveFiles]
- function CopyMoveFiles( const FromList, ToList: KOLString; Move: Boolean ): Boolean;
- begin
- Result := DoFileOp(FromList, ToList, FO_COPY - Integer( Move ),
- FOF_ALLOWUNDO, nil); //|\\ FO_COPY = 2, FO_MOVE = 1
-
- end;
-
- {-}
- //[function DiskFreeSpace]
- function DiskFreeSpace( const Path: KOLString ): I64;
- var
- FBA, TNB: I64;
- {$ifdef wince}
- begin
- GetDiskFreeSpaceEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
- {$else}
- type TGetDFSEx = function( Path: PKOLChar; CallerFreeBytes, TotalBytes, FreeBytes: Pointer )
- : Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var GetDFSEx: TGetDFSEx;
- Kern32: THandle;
- V: TOSVersionInfo;
- Ex: Boolean;
- SpC, BpS, NFC, TNC: DWORD;
- begin
- GetDFSEx := nil;
- V.dwOSVersionInfoSize := Sizeof( V );
- GetVersionEx
- ( POSVersionInfo( @ V )^ ); // bug in Windows.pas !
- Ex := FALSE;
- if V.dwPlatformId = VER_PLATFORM_WIN32_NT then
- begin
- Ex := V.dwMajorVersion >= 4;
- end
- else
- if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
- begin
- Ex := V.dwMajorVersion > 4;
- if not Ex then
- if V.dwMajorVersion = 4 then
- begin
- Ex := V.dwMinorVersion > 0;
- if not Ex then
- Ex := LoWord( V.dwBuildNumber ) >= $1111;
- end;
- end;
- if Ex then
- begin
- Kern32 := GetModuleHandle( 'kernel32' );
- GetDFSEx := GetProcAddress( Kern32, 'GetDiskFreeSpaceExA' );
- end;
- if Assigned( GetDFSEx ) then
- GetDFSEx( PKOLChar( Path ), @ FBA, @ TNB, @Result )
- else
- begin
- GetDiskFreeSpace( PKOLChar( Path ), SpC, BpS, NFC, TNC );
- Result := Mul64i( MakeInt64( SpC * BpS, 0 ), NFC );
- end;
- {$endif wince}
- end;
- {+}
-
- //[END FILES]
-
- //[function DoFileOp]
- function DoFileOp( const FromList, ToList: KOLString; FileOp: UINT; Flags: Word;
- Title: PKOLChar): Boolean;
- var FOS : {$IFDEF UNICODE_CTRLS}TSHFileOpStructW{$ELSE}TSHFileOpStruct{$ENDIF};
- Buf : PKOLChar;
- L : Integer;
- begin
- L := Length( FromList );
- Buf := AllocMem( L+2 );
- Move( FromList[ 1 ], Buf^, L );
- for L := L downto 0 do
- if Buf[ L ] = FileOpSeparator then Buf[ L ] := #0;
- FillChar( FOS, Sizeof( FOS ), #0 );
- if Applet <> nil then
- FOS.Wnd := Applet.Handle;
- FOS.wFunc := FileOp;
- FOS.lpszProgressTitle := Title;
- FOS.pFrom := Buf;
- FOS.pTo := PKOLChar( ToList + #0 );
- FOS.fFlags := Flags;
- FOS.fAnyOperationsAborted := True;
- Result := {$IFDEF UNICODE_CTRLS}SHFileOperationW{$ELSE}SHFileOperationA{$ENDIF}( FOS ) = 0;
- if Result then
- Result := not FOS.fAnyOperationsAborted;
- FreeMem( Buf );
- end;
- {$ENDIF WIN_GDI}
-
- {$IFDEF WIN}
- //[function DirIconSysIdxOffline]
- function DirIconSysIdxOffline( const Path: KOLString ): Integer;
- var SFI: TShFileInfo;
- begin
- SFI.iIcon := 0; // Bartov
- {$IFDEF UNICODE_CTRLS} ShGetFileInfoW {$ELSE} ShGetFileInfoA {$ENDIF}
- ( PKOLChar( Path ), FILE_ATTRIBUTE_DIRECTORY, SFI, sizeof( SFI ),
- SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES );
- Result := SFI.iIcon;
- end;
- {$ENDIF WIN}
-
- { TDirList }
-
- //[function NewDirList]
- function NewDirList( const DirPath, Filter: KOLString; Attr: DWORD ): PDirList;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PDirList.Create;*){--}
- Result.ScanDirectory( DirPath, Filter, Attr );
- end;
- //[END NewDirList]
-
- //[function NewDirListEx]
- function NewDirListEx( const DirPath, Filters: KOLString; Attr: DWORD ): PDirList;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PDirList.Create;*){--}
- Result.ScanDirectoryEx( DirPath, Filters, Attr );
- end;
- //[END NewDirListEx]
-
- //[procedure TDirList.Clear]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TDirList.Clear;
- begin
- if FList <> nil then
- FList.Release;
- FList := nil;
- end;
- {$ENDIF ASM_VERSION}
-
- //[destructor TDirList.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TDirList.Destroy;
- begin
- Clear;
- FPath := '';
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION FindFilter]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function FindFilter(const Filter: KOLString): KOLString;
- begin
- Result := Filter;
- if Result = '' then Result := '*.*';
- end;
- {$ENDIF ASM_VERSION}
- //[END FindFilter]
-
- //+
- //[function TDirList.Get]
- function TDirList.Get(Idx: Integer): PFindFileData;
- begin
- Result := FList.fItems[ Idx ];
- end;
-
- //[function TDirList.GetCount]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TDirList.GetCount: Integer;
- begin
- Result := 0;
- if FList = nil then Exit;
- Result := FList.Count;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TDirList.GetNames]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TDirList.GetNames(Idx: Integer): KOLString;
- begin
- Result := PKOLChar(@PFindFileData(fList.fItems[ Idx ]).cFileName[0]);
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TDirList.GetIsDirectory]
- function TDirList.GetIsDirectory(Idx: Integer): Boolean;
- begin
- Result := LongBool( Items[ Idx ].dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY );
- end;
-
- {$IFDEF ASM_noVERSION}
- //[function TDirList.SatisfyFilter]
- function TDirList.SatisfyFilter(FileName: PChar; FileAttr,
- FindAttr: DWord): Boolean;
- asm
- PUSH EBX
- PUSH ESI
- PUSH EDI
- XCHG EBX, EAX // EBX = @ Self
- MOV EAX, [FindAttr]
- MOV EDI, EDX // EDI = FileName
- MOV EDX, EAX
- AND EDX, ECX
- CMP EDX, EAX
- JE @@1
-
- TEST AL, FILE_ATTRIBUTE_NORMAL
- JZ @@ret_false
- @@1:
- CMP word ptr [EDI], '.'
- JE @@1_1
- CMP word ptr [EDI], '..'
- JNE @@1_1
- CMP byte ptr [EDI+2], 0
- JNE @@1_1
- @@1_0:
- MOV ECX, [FindAttr]
- TEST CL, FILE_ATTRIBUTE_NORMAL
- JZ @@1_1
- CMP ECX, FILE_ATTRIBUTE_NORMAL
- JE @@1_1
- TEST AL, FILE_ATTRIBUTE_DIRECTORY
- JZ @@1_1
- TEST CL, FILE_ATTRIBUTE_DIRECTORY
- JNZ @@ret_true
-
- @@1_1:
- MOV ECX, [EBX].fFilters
- JECXZ @@ret_false //?
-
- MOV ESI, [ECX].TStrList.fList
- MOV ESI, [ESI].TList.fItems
- MOV ECX, [ECX].TStrList.fCount
- JECXZ @@ret_false
-
- @@2:
- LODSD
- TEST EAX, EAX
- JZ @@nx_filter
-
- PUSHAD
-
- MOV EDX, [EAX]
- CMP DX, $002E
- JE @@F_d_dd
- AND EDX, $FFFFFF
- CMP EDX, $002E2E
- JE @@F_d_dd
-
- MOV EDX, [EDI]
- CMP DX, $002E
- JE @@4
- AND EDX, $FFFFFF
- CMP EDX, $002E2E
- JE @@4
- JMP @@chk_anti
-
- @@F_d_dd:
- MOV EDX, EDI
- PUSH EAX
- CALL StrComp
- TEST EAX, EAX
- POP EAX
- JZ @@popad_ret_true
-
- @@chk_anti:
- XCHG EDX, EAX // EDX = filter[ i ]
- MOV EAX, EDI // EAX = FileName
- CMP byte ptr [EDX], '^'
- JNE @@3
-
- INC EDX
- CALL _2StrSatisfy
- TEST AL, AL
- JZ @@4
- POPAD
- JMP @@ret_false
-
- @@3: CALL _2StrSatisfy
- TEST AL, AL
- JZ @@4
- @@popad_ret_true:
- POPAD
- @@ret_true:
- MOV AL, 1
- JMP @@exit
-
- @@4: POPAD
- @@nx_filter:
- LOOP @@2
-
- @@ret_false:
- XOR EAX, EAX
- @@exit:
- POP EDI
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TDirList.SatisfyFilter(FileName: PKOLChar; FileAttr,
- FindAttr: DWord): Boolean;
- {$IFDEF F_P}
- const Dot: String = '.';
- {$ENDIF F_P}
- var I: Integer;
- F: PKOLChar;
- HasOnlyNegFilters: Boolean;
- begin
- Result := (((FileAttr and FindAttr) = FindAttr) or
- LongBool(FindAttr and FILE_ATTRIBUTE_NORMAL));
- if not Result then Exit;
-
- if (FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' )
- {$ELSE} {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
- {$ENDIF UNICODE_CTRLS} ) and
- (FileName <> '..') then
- if LongBool( FindAttr and FILE_ATTRIBUTE_NORMAL ) and
- (FindAttr <> FILE_ATTRIBUTE_NORMAL) then
- if LongBool( FindAttr and FILE_ATTRIBUTE_DIRECTORY ) and
- LongBool( FileAttr and FILE_ATTRIBUTE_DIRECTORY ) then Exit;
-
- HasOnlyNegFilters := TRUE;
- for I := 0 to fFilters.Count - 1 do
- begin
- F := PKOLChar(fFilters.fList.fItems[ I ]);
- if F = '' then continue;
-
- if (F = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
- {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
- {$ENDIF UNICODE_CTRLS} ) or (F = '..') then
- begin
- if FileName = F then
- Exit;
- end
- else
- if (Filename = {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
- {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
- {$ENDIF UNICODE_CTRLS} ) or (FileName = '..') then
- continue;
-
- if F[ 0 ] = '^' then
- begin
- if StrSatisfy( FileName, PChar(@F[ 1 ]) ) then
- begin
- Result := False;
- Exit;
- end;
- end
- else
- begin
- HasOnlyNegFilters := FALSE;
- if StrSatisfy( FileName, F ) then
- begin
- Result := True;
- Exit;
- end;
- end;
- end;
-
- Result := HasOnlyNegFilters and
- (FileName <> {$IFDEF UNICODE_CTRLS} WideString( '.' ) {$ELSE}
- {$IFDEF F_P}Dot{$ELSE}'.'{$ENDIF}
- {$ENDIF UNICODE_CTRLS} ) and (FileName <> '..');
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_nononoVERSION}
- //[procedure TDirList.ScanDirectory]
- procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString;
- Attr: DWord);
- const sz_win32finddata = sizeof(TWin32FindData);
- asm
- PUSH EBX
- PUSH EDI
- MOV EBX, EAX
-
- PUSHAD
- CALL Clear
- CALL NewList
- MOV [EBX].fList, EAX
- POPAD
-
- PUSHAD
- LEA EAX, [EBX].fPath
- CALL System.@LStrAsg
- POPAD
-
- MOV EAX, [EBX].fPath
- TEST EAX, EAX
- JE @@exit
-
- PUSHAD
- LEA EDX, [EBX].fPath
- MOV EAX, [EDX]
- CALL IncludeTrailingPathDelimiter
-
- MOV EAX, [EBX].fFilters
- TEST EAX, EAX
- JNZ @@1
- CALL NewStrList
- MOV [EBX].fFilters, EAX
- POPAD
-
- PUSHAD
- PUSH ECX
- XCHG EAX, ECX
- MOV EDX, offset[@@star_d_star]
- CALL StrComp
- TEST AL, AL
- POP EDX
- JNZ @@asg_Filter
- MOV EDX, offset[@@star]
- @@asg_Filter:
- MOV EAX, [EBX].fFilters
- CALL TStrList.Add
- JMP @@1
-
- @@star_d_star:
- DB '*.*', 0
- DD -1, 1
- @@star: DB '*', 0
-
- @@1:
- POPAD
-
- ADD ESP, -sz_win32finddata
- XOR EDX, EDX
- PUSH EDX
- PUSH EDX
- XCHG EAX, ECX
- MOV EDX, ESP
- CALL FindFilter
-
- LEA EAX, [ESP+4]
- MOV EDX, [EBX].fPath
- POP ECX
- PUSH ECX
- CALL System.@LStrCat3
- CALL RemoveStr
-
- POP EAX
- MOV EDX, ESP
- PUSH EAX
- PUSH EDX
- PUSH EAX
- CALL FindFirstFile
- MOV EDI, EAX
- INC EAX
- MOV EAX, ESP
-
- PUSHFD
- CALL System.@LStrClr
- POPFD
- POP ECX
-
- JZ @@fin
-
- @@loop:
- MOV ECX, [ESP].TWin32FindData.dwFileAttributes
- PUSH [Attr]
- LEA EDX, [ESP+4].TWin32FindData.cFileName
- MOV EAX, EBX
- CALL SatisfyFilter
-
- TEST AL, AL
- JZ @@next
-
- MOV ECX, [EBX].fOnItem.TMethod.Code
- JECXZ @@accept
- MOV EAX, [EBX].fOnItem.TMethod.Data
- MOV ECX, ESP
- PUSH 1
- MOV EDX, ESP
- PUSH EDX
- MOV EDX, EBX
- CALL dword ptr [EBX].fOnItem.TMethod.Code
- POP ECX
- JECXZ @@next
- LOOP @@fin
-
- @@accept:
- MOV EAX, sz_win32finddata
- PUSH EAX
- CALL System.@GetMem
- PUSH EAX
- XCHG EDX, EAX
- MOV EAX, [EBX].fList
- CALL TList.Add
- POP EDX
- POP ECX
- MOV EAX, ESP
- CALL System.Move
-
- @@next:
- PUSH ESP
- PUSH EDI
- CALL FindNextFile
- TEST EAX, EAX
- JNZ @@loop
-
- PUSH EDI
- CALL FindClose
-
- @@fin:
- ADD ESP, sz_win32finddata
- @@exit:
- XOR EAX, EAX
- XCHG EAX, [EBX].fFilters
- CALL TObj.Free
- POP EDI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TDirList.ScanDirectory(const DirPath, Filter: KOLString;
- Attr: DWord);
- var FindData : TFindFileData;
- E : PFindFileData;
- Action: TDirItemAction;
- {$ifndef wince}
- {$IFDEF UNICODE_CTRLS}
- IsUnicode: AnsiString;
- {$ENDIF}
- {$endif wince}
- begin
- Clear;
- FList := NewList;
- FPath := DirPath;
- if FPath = '' then Exit;
- FPath := IncludeTrailingPathDelimiter( FPath );
- if fFilters = nil then
- begin
- fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
- if Filter = '*.*' then
- fFilters.Add( '*' )
- else
- fFilters.Add( Filter );
- end;
- if not Find_First( PKOLChar( FPath + FindFilter( Filter ) ), FindData ) then
- Exit;
- while True do
- begin
- {$ifndef wince}
- {$IFDEF UNICODE_CTRLS} //+MtsVN in 2.58 / 14Apr2007
- IsUnicode := FindData.cFileName;
- if (IsUnicode <> '.') and (IsUnicode <> '..') then
- begin
- if pos('?', IsUnicode) > 0 then
- CopyMemory( @FindData.cFileName, @FindData.cAlternateFileName,
- SizeOf(FindData.cAlternateFileName));
- end;
- {$ENDIF}
- {$endif wince}
- if SatisfyFilter( PKOLChar(@FindData.cFileName[0]),
- FindData.dwFileAttributes, Attr ) then
- begin
- Action := diAccept;
- if Assigned( OnItem ) then
- OnItem( @Self, FindData, Action );
- CASE Action OF
- diSkip: ;
- diAccept:
- begin
- GetMem( E, Sizeof( FindData ) );
- E^ := FindData;
- FList.Add( E );
- end;
- diCancel: break;
- END;
- end;
- if not Find_Next( FindData ) then break;
- end;
- Find_Close( FindData );
- fFilters.Free;
- fFilters := nil;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TDirList.ScanDirectoryEx]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TDirList.ScanDirectoryEx(const DirPath, Filters: KOLString;
- Attr: DWord);
- var F, FF: KOLString;
- begin
- FF := Filters;
- Free_And_Nil( fFilters );
- fFilters := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
- repeat
- F := Trim( Parse( FF, ';' ) );
- if F <> '' then
- fFilters.Add( F );
- until FF = '';
- ScanDirectory( DirPath, '', Attr );
- end;
- {$ENDIF ASM_VERSION}
-
- type
- PSortDirData = ^TSortDirData;
- TSortDirData = {$ifndef wince}packed{$endif} Record
- FoldersFirst, CaseSensitive : Boolean;
- Rules : array[ 0..11 ] of TSortDirRules;
- Dir : PDirList;
- end;
-
- //[FUNCTION CompareDirItems]
- {$IFDEF ASM_noVERSION}
- function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;
- asm
- PUSH EBX
- PUSH ESI
- PUSH EDI
- XCHG EBX, EAX
- MOV EAX, [EBX].TSortDirData.Dir
- MOV EAX, [EAX].TDirList.fList
- MOV EAX, [EAX].TList.fItems
- MOV ESI, [EAX+EDX*4]
- MOV EDI, [EAX+ECX*4]
- MOV DL, byte ptr[ESI].TWin32FindData.dwFileAttributes
- MOV DH, byte ptr[EDI].TWin32FindData.dwFileAttributes
- AND DX, 2020h
- XOR EAX, EAX
- CMP DL, DH
- JE @@1
- CMP [EBX].TSortDirData.FoldersFirst, AL
- JE @@1
- OR AL, DL
- JNE @@exit_near
- DEC EAX
- @@exit_near:
- POP EDI
- POP ESI
- POP EBX
- RET
-
- @@sdrByDateChanged:
- LEA EAX, [ESI].TWin32FindData.ftLastWriteTime
- LEA EDX, [EDI].TWin32FindData.ftLastWriteTime
- JMP @@sdrByDate1
-
- @@sdrByDateAccessed:
- LEA EAX, [ESI].TWin32FindData.ftLastAccessTime
- LEA EDX, [EDI].TWin32FindData.ftLastAccessTime
- JMP @@sdrByDate1
-
- @@jmp_table:
- DD offset[@@exit1], offset[@@2], offset[@@2]
- DD offset[@@sdrByName], offset[@@sdrByExt]
- DD offset[@@sdrBySize], offset[@@sdrBySize]
- DD offset[@@sdrByDateCreate], offset[@@sdrByDateChanged]
- DD offset[@@sdrByDateAccessed]
-
- @@1:
- LEA EDX, [EBX].TSortDirData.Rules
- PUSH EDX
- @@2:
- POP EDX
- XOR EAX, EAX
- MOV AL, [EDX]
- INC EDX
- PUSH EDX
-
- JMP dword ptr [@@jmp_table+EAX*4]
-
- @@sdrByDateCreate:
- LEA EAX, [ESI].TWin32FindData.ftCreationTime
- LEA EDX, [EDI].TWin32FindData.ftCreationTime
- @@sdrByDate1:
- PUSH EDX
- PUSH EAX
- CALL CompareFileTime
- TEST EAX, EAX
- JE @@2
- JMP @@exit1
-
- @@sdrBySize:
- MOV EAX, [ESI].TWin32FindData.nFileSizeHigh
- SUB EAX, [EDI].TWin32FindData.nFileSizeHigh
- JNE @@sdrBySize1
- MOV EAX, [ESI].TWin32FindData.nFileSizeLow
- SUB EAX, [EDI].TWin32FindData.nFileSizeLow
- @@to_2:
- JE @@2
- @@sdrBySize1:
- POP EDX
- DEC EDX
- CMP byte ptr[EDX], sdrBySizeDescending
- JNE @@sdrBySize2
- NEG EAX
- @@sdrBySize2:
- JNE @@exit
-
- DD -1, 1
- @@point:DB '.',0
-
- @@sdrByExt:
- LEA EAX, [EDI].TWin32FindData.cFileName
- MOV EDX, offset[@@point]
- PUSH EDX
- CALL __DelimiterLast
- POP EDX
- PUSH EAX
- LEA EAX, [ESI].TWin32FindData.cFileName
- CALL __DelimiterLast
- POP EDX
- JMP @@sdrByName0
-
- @@sdrByName:
- LEA EAX, [ESI].TWin32FindData.cFileName
- LEA EDX, [EDI].TWin32FindData.cFileName
- @@sdrByName0:
- CMP [EBX].TSortDirData.CaseSensitive, 0
- JNE @@sdrByName1
- CALL _AnsiCompareStrNoCase
- JMP @@sdrByName2
- @@sdrByName1:
- CALL _AnsiCompareStr
- @@sdrByName2:
- TEST EAX, EAX
- JE @@to_2
- //JMP @@exit1
-
- @@exit1:
- POP EDX
- @@exit:
- POP EDI
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function CompareDirItems( const Data : PSortDirData; const e1, e2 : DWORD ) : Integer;
- var I : Integer;
- Item1, Item2 : PFindFileData;
- S1, S2 : PKOLChar;
- IsDir1, IsDir2 : Boolean;
- Date1, Date2 : PFileTime;
- begin
- Item1 := Data.Dir.fList.fItems[ e1 ];
- Item2 := Data.Dir.fList.fItems[ e2 ];
- Result := 0;
- IsDir1 := (Item1.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
- IsDir2 := (Item2.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;
- if (IsDir1 <> IsDir2) and Data.FoldersFirst then
- begin
- if IsDir1 then Result := -1 else Result := 1;
- exit;
- end;
- for I := 0 to High(Data.Rules) do
- begin
- case Data.Rules[ I ] of
- sdrByName:
- begin
- S1 := Item1.cFileName;
- S2 := Item2.cFileName;
- if not Data.CaseSensitive then
- Result := {$IFDEF UNICODE_CTRLS}
- WStrComp( AnsiUpperCase( S1 ), AnsiUpperCase( S2 ) )
- {$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
- else
- Result := {$IFDEF UNICODE_CTRLS}
- _WStrComp( S1, S2 )
- {$ELSE}
- _AnsiCompareStr( S1, S2 )
- {$ENDIF};
- end;
- sdrByExt:
- begin
- S1 := Item1.cFileName;
- S2 := Item2.cFileName;
- S1 := {$IFDEF UNICODE_CTRLS} @ S1[ DelimiterLast( WideString( S1 ), '.' ) - 1 ]
- {$ELSE} __DelimiterLast( S1, '.' ) {$ENDIF};
- S2 := {$IFDEF UNICODE_CTRLS} @ S2[ DelimiterLast( WideString( S2 ), '.' ) - 1 ]
- {$ELSE} __DelimiterLast( S2, '.' ) {$ENDIF};
- if not Data.CaseSensitive then
- Result := {$IFDEF UNICODE_CTRLS}
- WStrComp( WAnsiUpperCase( S1 ), WAnsiUpperCase( S2 ) )
- {$ELSE} _AnsiCompareStrNoCase( S1, S2 ) {$ENDIF}
- else
- Result := {$IFDEF UNICODE_CTRLS} WStrComp( S1, S2 )
- {$ELSE} _AnsiCompareStr( S1, S2 ) {$ENDIF};
- end;
- sdrBySize, sdrBySizeDescending:
- begin
- if Item1.nFileSizeHigh < Item2.nFileSizeHigh then
- Result := -1
- else
- if Item1.nFileSizeHigh > Item2.nFileSizeHigh then
- Result := 1
- else
- if Item1.nFileSizeLow < Item2.nFileSizeLow then
- Result := -1
- else
- if Item1.nFileSizeLow > Item2.nFileSizeLow then
- Result := 1;
- if Data.Rules[ I ] = sdrBySizeDescending then
- Result := -Result;
- end;
- sdrByDateCreate:
- begin
- Date1 := @Item1.ftCreationTime;
- Date2 := @Item2.ftCreationTime;
- Result := FileTimeCompare( Date1^, Date2^ );
- end;
- sdrByDateChanged:
- begin
- Date1 := @Item1.ftLastWriteTime;
- Date2 := @Item2.ftLastWriteTime;
- Result := FileTimeCompare( Date1^, Date2^ );
- end;
- sdrByDateAccessed:
- begin
- Date1 := @Item1.ftLastAccessTime;
- Date2 := @Item2.ftLastAccessTime;
- Result := FileTimeCompare( Date1^, Date2^ );
- end;
- end; {case}
- if Result <> 0 then break;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareDirItems]
-
- //[PROCEDURE SwapDirItems]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure SwapDirItems( const Data : PSortDirData; const e1, e2 : DWORD );
- var Tmp : Pointer;
- begin
- Tmp := Data.Dir.FList.fItems[ e1 ];
- Data.Dir.FList.fItems[ e1 ] := Data.Dir.FList.fItems[ e2 ];
- Data.Dir.FList.fItems[ e2 ] := Tmp;
- end;
- {$ENDIF ASM_VERSION}
- //[END SwapDirItems]
-
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TDirList.Sort(Rules: array of TSortDirRules);
- var SortDirData : TSortDirData;
- I, J : Integer;
-
- function RulePresent( Rule : TSortDirRules ) : Boolean;
- var K : Integer;
- begin
- Result := True;
- for K := J - 1 downto 0 do
- if Rule = SortDirData.Rules[ K ] then exit;
- Result := False;
- end;
-
- procedure AddRule( Rule : TSortDirRules );
- begin
- if J > High( SortDirData.Rules ) then exit;
- if RulePresent( Rule ) then exit;
- SortDirData.Rules[ J ] := Rule;
- Inc( J );
- end;
- begin
- if fList = nil then Exit;
- J := 0;
- for I := 0 to High(Rules) do
- AddRule( Rules[ I ] );
- for I := 0 to High(DefSortDirRules) do
- AddRule( DefSortDirRules[ I ] );
- while J < High( SortDirData.Rules ) do
- begin
- SortDirData.Rules[ J ] := sdrNone;
- Inc( J );
- end;
-
- SortDirData.Dir := @Self;
- SortDirData.FoldersFirst := RulePresent( sdrFoldersFirst );
- SortDirData.CaseSensitive := RulePresent( sdrCaseSensitive );
- SortData( Pointer( @SortDirData ), fList.fCount, @CompareDirItems, @SwapDirItems );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TDirList.FileList]
- function TDirList.FileList(const Separator: KOLString; Dirs,
- FullPaths: Boolean): KOLString;
- var I: Integer;
- begin
- Result := '';
- for I := 0 to Count-1 do
- begin
- if not Dirs and IsDirectory[ I ] then Continue;
- if FullPaths then
- Result := Result + Path;
- Result := Result + Names[ I ] + Separator;
- end;
- end;
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- ////////////////////////////////////////////////////////////////////////
- // R E G I S T R Y
- ////////////////////////////////////////////////////////////////////////
-
- {++}(*
- function RegSetValueEx; external advapi32 name 'RegSetValueExA';
- *){--}
-
- { -- registry -- }
-
- //[function RegKeyOpenRead]
- function RegKeyOpenRead( Key: HKey; const SubKey: KOLString ): HKey;
- begin
- if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then
- Result := 0;
- end;
-
- //[function RegKeyOpenWrite]
- function RegKeyOpenWrite( Key: HKey; const SubKey: KOLString ): HKey;
- begin
- if RegOpenKeyEx( Key, PKOLChar( SubKey ), 0, KEY_READ or KEY_WRITE, Result ) <> ERROR_SUCCESS then
- Result := 0;
- end;
-
- //[function RegKeyOpenCreate]
- function RegKeyOpenCreate( Key: HKey; const SubKey: KOLString ): HKey;
- var dwDisp: DWORD;
- begin
- if RegCreateKeyEx( Key, PKOLChar( SubKey ), 0, nil, 0, KEY_ALL_ACCESS, nil, Result,
- @dwDisp ) <> ERROR_SUCCESS then
- Result := 0;
- end;
-
- //[function RegKeyGetDw]
- function RegKeyGetDw( Key: HKey; const ValueName: KOLString ): DWORD;
- var dwType, dwSize: DWORD;
- begin
- dwSize := sizeof( DWORD );
- Result := 0;
- if (Key = 0) or
- (RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType, PByte( @Result ), @dwSize ) <> ERROR_SUCCESS)
- or (dwType <> REG_DWORD) then Result := 0;
- end;
-
- //[function RegKeyGetStr]
- function RegKeyGetStr( Key: HKey; const ValueName: KOLString ): KOLString;
- var dwType, dwSize: DWORD;
- Buffer: PKOLChar;
-
- function Query: Boolean;
- begin
- Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
- Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
- end;
- begin
- Result := '';
- if Key = 0 then Exit;
- dwSize := 0;
- Buffer := nil;
- if not Query or (dwType <> REG_SZ) then Exit;
- GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
- if Query then
- Result := Buffer;
- FreeMem( Buffer );
- end;
-
- //[function RegKeyGetStrEx]
- function RegKeyGetStrEx( Key: HKey; const ValueName: KOLString ): KOLString;
- var dwType, dwSize: DWORD;
- Buffer: PKOLChar;
- {$ifdef win32}
- Buffer2: PKOLChar;
- Sz: Integer;
- {$endif win32}
- function Query: Boolean;
- begin
- Result := RegQueryValueEx( Key, PKOLChar( ValueName ), nil, @dwType,
- Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
- end;
- begin
- Result := '';
- if Key = 0 then Exit;
- dwSize := 0;
- Buffer := nil;
- if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then Exit;
- GetMem( Buffer, dwSize * Sizeof( KOLChar ) );
- if Query then
- begin
- {$ifdef win32}
- if dwtype = REG_EXPAND_SZ then
- begin
- Sz := ExpandEnvironmentStrings(Buffer,nil,0); // bug in size detection! sometimes we get an additional 2 bytes at the end...
- GetMem(Buffer2,Sz * Sizeof( KOLChar )); //
- ExpandEnvironmentStrings(Buffer, Buffer2, Sz); //
- Result:=Buffer2; //
- FreeMem(Buffer2); //
- end
- else
- {$endif win32}
- Result := Buffer;
- end;
- FreeMem( Buffer );
- end;
-
- //[function RegKeySetDw]
- function RegKeySetDw( Key: HKey; const ValueName: KOLString; Value: DWORD ): Boolean;
- begin
- Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
- REG_DWORD, @Value, sizeof( DWORD ) ) = ERROR_SUCCESS);
- end;
-
- //[function RegKeySetStr]
- function RegKeySetStr( Key: HKey; const ValueName: KOLString; const Value: KOLString ): Boolean;
- begin
- Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
- REG_SZ, PKOLChar(Value),
- (Length( Value ) + 1)*Sizeof(KOLChar) ) = ERROR_SUCCESS);
- end;
-
- //[function RegKeySetStrEx]
- function RegKeySetStrEx( Key: HKey; const ValueName: KOLString; const Value: KOLString;
- expand: boolean): Boolean;
- var dwType: DWORD;
- begin
- dwType := REG_SZ;
- if expand then
- dwType := REG_EXPAND_SZ;
- Result := (Key <> 0) and (RegSetValueEx(Key, PKOLChar(ValueName), 0, dwType,
- PKOLChar(Value), (Length(Value) + 1)*Sizeof(KOLChar)) = ERROR_SUCCESS);
- end;
-
- //[procedure RegKeyClose]
- procedure RegKeyClose( Key: HKey );
- begin
- if Key <> 0 then
- RegCloseKey( Key );
- end;
-
- //[function RegKeyDelete]
- function RegKeyDelete( Key: HKey; const SubKey: KOLString ): Boolean;
- begin
- Result := FALSE;
- if Key <> 0 then
- Result := RegDeleteKey( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
- end;
-
- //[function RegKeyDeleteValue]
- function RegKeyDeleteValue( Key: HKey; const SubKey: KOLString ): Boolean;
- begin
- Result := FALSE;
- if Key <> 0 then
- Result := RegDeleteValue( Key, PKOLChar( SubKey ) ) = ERROR_SUCCESS;
- end;
-
- //[function RegKeyExists]
- function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;
- var K: Integer;
- begin
- if Key = 0 then
- begin
- Result := FALSE;
- Exit;
- end;
- K := RegKeyOpenRead( Key, SubKey );
- Result := K <> 0;
- if K <> 0 then
- RegKeyClose( K );
- end;
-
- //[function RegKeyValExists]
- function RegKeyValExists( Key: HKey; const ValueName: KOLString ): Boolean;
- var dwType, dwSize: DWORD;
- begin
- Result := (Key <> 0) and
- (RegQueryValueEx( Key, PKOLChar( ValueName ), nil,
- @dwType, nil, @dwSize ) = ERROR_SUCCESS);
- end;
-
- //[function RegKeyValueSize]
- function RegKeyValueSize( Key: HKey; const ValueName: KOLString ): Integer;
- begin
- Result := 0;
- if Key = 0 then Exit;
- RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, nil, @ DWORD( Result ) );
- end;
-
- //[function RegKeyGetBinary]
- function RegKeyGetBinary( Key: HKey; const ValueName: KOLString; var Buffer; Count: Integer ): Integer;
- begin
- Result := 0;
- if Key = 0 then Exit;
- Result := Count;
- if RegQueryValueEx( Key, PKOLChar( ValueName ), nil, nil, @ Buffer, @ Result ) <> 0 then
- Result:=0;
- end;
-
- //[function RegKeySetBinary]
- function RegKeySetBinary( Key: HKey; const ValueName: KOLString; const Buffer; Count: Integer ): Boolean;
- begin
- Result := (Key <> 0) and (RegSetValueEx( Key, PKOLChar( ValueName ), 0,
- REG_BINARY, @ Buffer, Count ) = ERROR_SUCCESS);
- end;
-
- //[function RegKeyGetDateTime]
- function RegKeyGetDateTime(Key: HKey; const ValueName: KOLString): TDateTime;
- begin
- if RegKeyGetBinary( Key, ValueName, Result, Sizeof( Result ) ) <> Sizeof( Result ) then
- Result:=0;
- end;
-
- //[function RegKeySetDateTime]
- function RegKeySetDateTime(Key: HKey; const ValueName: KOLString; DateTime: TDateTime): Boolean;
- begin
- Result := RegKeySetBinary( Key, ValueName, DateTime, Sizeof( DateTime ) );
- end;
-
- {$IFDEF OLD_REGKEYGETSUBKEYS}
- //-----------------------------------------------
- // functions by Valerian Luft <luft@valerian.de>
- //-----------------------------------------------
- //[function RegKeyGetSubKeys]
- function RegKeyGetSubKeys( const Key: HKEY; List: PStrList) : Boolean;
- var
- I, Size, NumSubKeys, MaxSubKeyLen : DWORD;
- KeyName: KOLString;
- begin
- Result := False;
- List.Clear ;
- if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil,
- nil, nil) = ERROR_SUCCESS then
- begin
- if NumSubKeys > 0 then begin
- for I := 0 to NumSubKeys-1 do
- begin
- Size := MaxSubKeyLen+1;
- SetLength(KeyName, Size);
- //FillChar(KeyName[1],Size,#0);
- RegEnumKeyEx(Key, I, @KeyName[1], Size, nil, nil, nil, nil);
- SetLength(KeyName, {$ifdef UNICODE_CTRLS}WStrLen{$else}StrLen{$endif}(@KeyName[1]));
- List.Add(KeyName);
- end;
- end;
- Result:= True;
- end;
- end;
- {$ELSE} // new (faster) version by Alex Shyshko (Psychedelic)
- function RegKeyGetSubKeys(const Key: HKEY; List: PStrList) : Boolean;
- var
- i, MaxSubKeyLen, Size: DWORD;
- Buf: PKOLchar;
- begin
- Result:=false;
- List.Clear;
- if RegQueryInfoKey(Key, nil, nil, nil, nil, @MaxSubKeyLen, nil, nil, nil, nil,
- nil, nil) = ERROR_SUCCESS then
- begin
- if MaxSubKeyLen > 0 then
- begin
- Inc(MaxSubKeyLen);
- GetMem(Buf,MaxSubKeyLen*SizeOfKOLChar);
- i:=0;
- while True do begin
- Size:=MaxSubKeyLen;
- if RegEnumKeyEx(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_SUCCESS then
- break;
- List.Add(Buf);
- inc(i);
- end;
- FreeMem(Buf);
- end; // if MaxSubKeyLen
- Result:=true;
- end; // if RegQueryInfoKey
- end;
- {$ENDIF}
-
- //[function RegKeyGetValueNames]
- {$IFDEF OLD_REGKEYGETVALUENAMES}
- function RegKeyGetValueNames(const Key: HKEY; List: PStrList): Boolean;
- var
- I, Size, NumSubKeys, NumValueNames, MaxValueNameLen: DWORD;
- ValueName: String;
- begin
- List.Clear ;
- Result:=False;
- if RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys, nil, nil, @NumValueNames,
- @MaxValueNameLen, nil, nil, nil) = ERROR_SUCCESS then
- begin
- if NumValueNames > 0 then
- for I := 0 to NumValueNames - 1 do begin
- Size := MaxValueNameLen + 1;
- SetLength(ValueName, Size);
- //FillChar(ValueName[1],Size,#0);
- RegEnumValue(Key, I, @ValueName[1], Size, nil, nil, nil, nil);
- SetLength(ValueName, {$ifdef UNICODE_CTRLS}WStrLen{$else}StrLen{$endif}(@ValueName[1]));
- List.Add(ValueName);
- end;
- Result := True;
- end ;
- end;
- {$ELSE} // new (faster) version by Alex Shyshko (Psychedelic)
- function RegKeyGetValueNames(const Key: HKEY; List: PStrList) : Boolean;
- var
- i, MaxValueNameLen, Size: DWORD;
- Buf: PKOLchar;
- begin
- Result:=false;
- List.Clear;
-
- if RegQueryInfoKey(Key, nil, nil, nil, nil, nil, nil, nil, @MaxValueNameLen, nil,
- nil, nil) = ERROR_SUCCESS then
- begin
- if MaxValueNameLen > 0 then
- begin
- GetMem(Buf,MaxValueNameLen + SizeOf(KOLChar) );
- i:=0;
- Size:=MaxValueNameLen+1;
-
- while RegEnumValue(Key,i,buf,Size,nil,nil,nil,nil) <> ERROR_NO_MORE_ITEMS do
- begin
- List.Add(Buf);
- Size:=MaxValueNameLen+1;
- inc(i);
- end;
-
- FreeMem(Buf {,MaxValueNameLen + ... system always knows how long buffer is});
- end; // if MaxValueNameLen
- Result:=true;
- end; // if RegQueryInfoKey
-
- end;
- {$ENDIF}
-
- //[function RegKeyGetValueTyp]
- function RegKeyGetValueTyp (const Key:HKEY; const ValueName: KOLString) : DWORD;
- begin
- Result:= Key ;
- if Key <> 0 then
- RegQueryValueEx (Key,@ValueName[1],NIL,@Result,NIL,NIL)
- end;
-
- //////////////////////////////////////////////////////////////////////
- // D A T E A N D T I M E
- //////////////////////////////////////////////////////////////////////
-
- { -- date and time utilities -- }
-
- {* This part of the unit contains date-time routines. It is not a simple compilation
- of Delphi VCL date-time. E.g., TDateTime type is not based on 31-Dec-1899,
- but it is based on 31-Dec-0000 instead, allowing easy manipulating of dates
- at all Christian era, and all other historical era too. }
-
- //[procedure DivMod]
- procedure DivMod(Dividend: Integer; Divisor: Word;
- var Result, Remainder: Word);
- {$ifdef cpu86}
- asm
- PUSH EBX
- MOV EBX,EDX
- MOV EDX,EAX
- SHR EDX,16
- DIV BX
- MOV EBX,Remainder
- MOV [ECX],AX
- MOV [EBX],DX
- POP EBX
- end;
- {$else}
- begin
- Result := Dividend div Divisor;
- Remainder := Dividend mod Divisor;
- end;
- {$endif cpu86}
-
- {++}(*
- //[API GetLocalTime, GetSystemTime]
- procedure GetLocalTime; external kernel32 name 'GetLocalTime';
- procedure GetSystemTime; external kernel32 name 'GetSystemTime';
- *){--}
-
- //*
- //[function Now]
- function Now : TDateTime;
- var SystemTime : TSystemTime;
- begin
- GetLocalTime( SystemTime );
- SystemTime2DateTime( SystemTime, Result );
- end;
-
- //[function Date]
- function Date: TDateTime;
- begin
- Result := Trunc( Now );
- end;
-
- //[procedure DecodeDateFully]
- procedure DecodeDateFully( DateTime: TDateTime; var Year, Month, Day, DayOfWeek: WORD );
- var ST: TSystemTime;
- begin
- DateTime2SystemTime( DateTime, ST );
- Year := ST.wYear;
- Month := ST.wMonth;
- Day := ST.wDay;
- DayOfWeek := ST.wDayOfWeek;
- end;
-
- //[procedure DecodeDate]
- procedure DecodeDate( DateTime: TDateTime; var Year, Month, Day: WORD );
- var Dummy: Word;
- begin
- DecodeDateFully( DateTime, Year, Month, Day, Dummy );
- end;
-
- //[function EncodeDate]
- function EncodeDate( Year, Month, Day: WORD; var DateTime: TDateTime ): Boolean;
- var ST: TSystemTime;
- begin
- FillChar( ST, Sizeof( ST ), #0 );
- ST.wYear := Year;
- ST.wMonth := Month;
- ST.wDay := Day;
- Result := SystemTime2DateTime( ST, DateTime );
- end;
-
- //[procedure IncDays]
- procedure IncDays( var SystemTime : TSystemTime; DaysNum : Integer );
- var DateTime : TDateTime;
- begin
- SystemTime2DateTime( SystemTime, DateTime );
- DateTime := DateTime + DaysNum;
- DateTime2SystemTime( DateTime, SystemTime );
- end;
-
- //*
- //[procedure IncMonths]
- procedure IncMonths( var SystemTime : TSystemTime; MonthsNum : Integer );
- var M : Integer;
- DateTime : TDateTime;
- begin
- M := SystemTime.wMonth + MonthsNum - 1;
- Inc( SystemTime.wYear, M div 12 );
- SystemTime.wMonth := M mod 12 + 1;
-
- // Normalize wDayOfWeek field:
- SystemTime2DateTime( SystemTime, DateTime );
- DateTime2SystemTime( DateTime, SystemTime );
- end;
-
- //*
- //[function IsLeapYear]
- function IsLeapYear(Year: Integer): Boolean;
- begin
- Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
- end;
-
- //*
- //[function SystemTime2DateTime]
- function SystemTime2DateTime(const SystemTime : TSystemTime; var DateTime : TDateTime ) : Boolean;
- var I : Integer;
- _Day : Integer;
- DayTable: PDayTable;
- begin
- Result := False;
- DateTime := 0.0;
- DayTable := @MonthDays[IsLeapYear(SystemTime.wYear)];
- with SystemTime do
- if {(wYear >= 0) !always true! and} (wYear <= 9999) and
- {(wMonth >= 1) and !otherwise can not convert time only!}
- (wMonth <= 12) and
- {(wDay >= 1) and !otherwise can not convert time only!}
- (wDay <= DayTable^[wMonth]) and //
- (wHour < 24) and (wMinute < 60) and (wSecond < 60) and (wMilliSeconds < 1000) then //
- begin
- _Day := wDay;
- for I := 1 to wMonth - 1 do
- Inc(_Day, DayTable^[I]);
- I := wYear - 1;
- //--------------- by Vadim Petrov ------++
- if I<0 then i := 0; //
- //--------------------------------------++
- DateTime := I * 365 + I div 4 - I div 100 + I div 400 + _Day
- + (LongInt(wHour) * 3600000 + LongInt(wMinute) * 60000 + LongInt(wSecond) * 1000 + LongInt(wMilliSeconds)) / MSecsPerDay;
- Result := True;
- end;
- end;
-
- //*
- //[function DayOfWeek]
- function DayOfWeek(Date: TDateTime): Integer;
- begin
- Result := (Trunc( Date ) + 6) mod 7;
- end;
-
- //*
- //[function DateTime2SystemTime]
- function DateTime2SystemTime(const DateTime : TDateTime; var SystemTime : TSystemTime ) : Boolean;
- const
- D1 = 365;
- D4 = D1 * 4 + 1;
- D100 = D4 * 25 - 1;
- D400 = D100 * 4 + 1;
- var Days : Integer;
- Y, M, D, I: Word;
- MSec : Integer;
- DayTable: PDayTable;
- MinCount, MSecCount: Word;
- begin
- Days := Trunc( DateTime );
- MSec := Round((DateTime - Days) * MSecsPerDay);
- Result := False;
- with SystemTime do
- if Days > 0 then
- begin
- Dec(Days);
- Y := 1;
- while Days >= D400 do
- begin
- Dec(Days, D400);
- Inc(Y, 400);
- end;
- DivMod(Days, D100, I, D);
- if I = 4 then
- begin
- Dec(I);
- Inc(D, D100);
- end;
- Inc(Y, I * 100);
- DivMod(D, D4, I, D);
- Inc(Y, I * 4);
- DivMod(D, D1, I, D);
- if I = 4 then
- begin
- Dec(I);
- Inc(D, D1);
- end;
- Inc(Y, I);
- DayTable := @MonthDays[IsLeapYear(Y)];
- M := 1;
- while True do
- begin
- I := DayTable^[M];
- if D < I then Break;
- Dec(D, I);
- Inc(M);
- end;
- wYear := Y;
- wMonth := M;
- wDay := D + 1;
- wDayOfWeek := KOL.DayOfWeek( DateTime );
- DivMod(MSec, 60000, MinCount, MSecCount);
- DivMod(MinCount, 60, wHour, wMinute);
- DivMod(MSecCount, 1000, wSecond, wMilliSeconds);
- Result := True;
- end;
- end;
-
- function DateTime_DiffSysLoc: TDateTime;
- var ST, LT: TSystemTime;
- FT, FT1: TFileTime;
- D1, D2: TDateTime;
- begin
- GetSystemTime( ST );
- SystemTimeToFileTime( ST, FT );
- FileTimeToLocalFileTime( FT, FT1 );
- FileTimeToSystemTime( FT1, LT );
- SystemTime2DateTime( ST, D1 );
- SystemTime2DateTime( LT, D2 );
- Result := D2 - D1;
- end;
-
- //[function DateTime_System2Local]
- function DateTime_System2Local( DTSys: TDateTime ): TDateTime;
- begin
- Result := DTSys + DateTime_DiffSysLoc;
- end;
-
- //[function DateTime_Local2System]
- function DateTime_Local2System( DTLoc: TDateTime ): TDateTime;
- begin
- Result := DTLoc - DateTime_DiffSysLoc;
- end;
-
- function FileTime2DateTime( const ft: TFileTime; var DT: TDateTime ): Boolean;
- var ft1: TFileTime;
- st: TSystemTime;
- begin
- Result := FileTimeToLocalFileTime( ft, ft1 ) and
- FileTimeToSystemTime( ft1, st ) and
- SystemTime2DateTime( st, dt );
- end;
-
- function DateTime2FileTime( DT: TDateTime; var ft: TFileTime ): Boolean;
- var st: TSystemTime;
- begin
- Result := DateTime2SystemTime( DT, ST ) and
- SystemTimeToFileTime( st, ft ) and
- LocalFileTimeToFileTime( ft, ft );
- end;
-
- //*
- //[function SystemDate2Str]
- function SystemDate2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
- const DfltDateFormat : TDateFormat;
- const DateFormat : PKOLChar ) : KOLString;
- var Buf : PKOLChar;
- Sz : Integer;
- Flags : DWORD;
- begin
- Sz := 100;
- Buf := nil;
- Result := '';
- Flags := 0;
- if DateFormat = nil then
- if DfltDateFormat = dfShortDate then
- Flags := DATE_SHORTDATE
- else
- Flags := DATE_LONGDATE;
- while True do
- begin
- if Buf <> nil then
- FreeMem( Buf );
- GetMem( Buf, Sz * Sizeof( KOLChar ) );
- if Buf = nil then Exit;
- if GetDateFormat( LocaleID, Flags, @SystemTime, DateFormat, Buf, Sz )
- = 0 then
- begin
- if GetLastError = ERROR_INSUFFICIENT_BUFFER then
- Sz := Sz * 2
- else
- break;
- end
- else
- begin
- Result := Buf;
- break;
- end;
- end;
- if Buf <> nil then
- FreeMem( Buf );
- end;
-
- //*
- //[function SystemTime2Str]
- function SystemTime2Str( const SystemTime : TSystemTime; const LocaleID : DWORD;
- const Flags : TTimeFormatFlags;
- const TimeFormat : PKOLChar ) : KOLString;
- var Buf : PKOLChar;
- Sz : Integer;
- Flg : DWORD;
- begin
- Sz := 100;
- Buf := nil;
- Result := '';
- Flg := 0;
- if tffNoMinutes in Flags then
- Flg := TIME_NOMINUTESORSECONDS
- else
- if tffNoSeconds in Flags then
- Flg := TIME_NOSECONDS;
- if tffNoMarker in Flags then
- Flg := Flg or TIME_NOTIMEMARKER;
- if tffForce24 in Flags then
- Flg := Flg or TIME_FORCE24HOURFORMAT;
- while True do
- begin
- if Buf <> nil then
- FreeMem( Buf );
- GetMem( Buf, Sz * Sizeof( KOLChar ) );
- if Buf = nil then Exit;
- if GetTimeFormat( LocaleID, Flg, @SystemTime, TimeFormat, Buf, Sz )
- = 0 then
- begin
- if GetLastError = ERROR_INSUFFICIENT_BUFFER then
- Sz := Sz * 2
- else
- break;
- end
- else
- begin
- Result := Buf;
- break;
- end;
- end;
- if Buf <> nil then
- FreeMem( Buf );
- end;
-
- //[function Date2StrFmt]
- function Date2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
- var ST: TSystemTime;
- lpFmt: PKOLChar;
- begin
- DateTime2SystemTime( D, ST );
- lpFmt := nil;
- if Fmt <> '' then lpFmt := PKOLChar( Fmt );
- Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT, dfShortDate, lpFmt );
- end;
-
- //[function Time2StrFmt]
- function Time2StrFmt( const Fmt: KOLString; D: TDateTime ): KOLString;
- var ST: TSystemTime;
- lpFmt: PKOLChar;
- begin
- if D < 1 then D := D + 1;
- DateTime2SystemTime( D, ST );
- lpFmt := nil;
- if Fmt <> '' then lpFmt := PKOLChar( Fmt );
- Result := SystemTime2Str( ST, LOCALE_USER_DEFAULT, [], lpFmt );
- end;
-
- //[function DateTime2StrShort]
- function DateTime2StrShort( D: TDateTime ): String;
- var ST: TSystemTime;
- begin
- //--------- by Vadim Petrov --------++
- if D < 1 then D := D + 1; //
- //----------------------------------++
- DateTime2SystemTime( D, ST );
- Result := SystemDate2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, dfShortDate, nil ) + ' ' +
- SystemTime2Str( ST, LOCALE_USER_DEFAULT {GetUserDefaultLCID}, [], nil );
- end;
-
- //[function Str2DateTimeFmt]
- function Str2DateTimeFmt( const sFmtStr, sS: KOLString ): TDateTime;
- var h12, hAM: Boolean;
- FmtStr, S: PKOLChar;
-
- function GetNum( var S: PKOLChar; NChars: Integer ): Integer;
- begin
- Result := 0;
- while (S^ <> #0) and (NChars <> 0) do
- begin
- Dec( NChars );
- {$IFDEF UNICODE_CTRLS}
- if (S^ >= '0') and (S^ <= '9') then
- {$ELSE}
- if S^ in ['0'..'9'] then
- {$ENDIF}
- begin
- Result := Result * 10 + Ord(S^) - Ord('0');
- Inc( S );
- end
- else
- break;
- end;
- end;
-
- function GetYear( var S: PKOLChar; NChars: Integer ): Integer;
- var STNow: TSystemTime;
- OldDate: Boolean;
- begin
- Result := GetNum( S, NChars );
- GetSystemTime( STNow );
- OldDate := Result < 50;
- Result := Result + STNow.wYear - STNow.wYear mod 100;
- if OldDate then Dec( Result, 100 );
- end;
-
- function GetMonth( const fmt: KOLString; var S: PKOLChar ): Integer;
- var SD: TSystemTime;
- M: Integer;
- C, MonthStr: KOLString;
- begin
- GetSystemTime( SD );
- for M := 1 to 12 do
- begin
- SD.wMonth := M;
- C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/dd/yyyy/' ) );
- MonthStr := Parse( C, '/' );
- if AnsiCompareStrNoCase( MonthStr, Copy( S, 1, Length( MonthStr ) ) ) = 0 then
- begin
- Result := M;
- Inc( S, Length( MonthStr ) );
- Exit;
- end;
- end;
- Result := 1;
- end;
-
- procedure SkipDayOfWeek( const fmt: KOLString; var S: PKOLChar );
- var SD: TSystemTime;
- Dt: TDateTime;
- D: Integer;
- C, DayWeekStr: KOLString;
- begin
- GetSystemTime( SD );
- SystemTime2DateTime( SD, Dt );
- Dt := Dt - SD.wDayOfWeek;
- for D := 0 to 6 do
- begin
- DateTime2SystemTime( Dt, SD );
- C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/MM/yyyy/' ) );
- DayWeekStr := Parse( C, '/' );
- if AnsiCompareStrNoCase( DayWeekStr, Copy( S, 1, Length( DayWeekStr ) ) ) = 0 then
- begin
- Inc( S, Length( DayWeekStr ) );
- Exit;
- end;
- Dt := Dt + 1.0;
- end;
- end;
-
- procedure GetTimeMark( const fmt: KOLString; var S: PKOLChar );
- var SD: TSystemTime;
- AM: Boolean;
- C, TimeMarkStr: KOLString;
- begin
- GetSystemTime( SD );
- SD.wHour := 0;
- for AM := FALSE to TRUE do
- begin
- C := SystemDate2Str( SD, LOCALE_USER_DEFAULT, dfLongDate, PKOLChar( fmt + '/HH/mm' ) );
- TimeMarkStr := Parse( C, '/' );
- if AnsiCompareStrNoCase( TimeMarkStr, Copy( S, 1, Length( TimeMarkStr ) ) ) = 0 then
- begin
- Inc( S, Length( TimeMarkStr ) );
- hAM := AM;
- Exit;
- end;
- SD.wHour := 13;
- end;
- Result := 1;
- end;
-
- function FmtIs1( S: PKOLChar ): Boolean;
- begin
- if StrIsStartingFrom( FmtStr, S ) then
- begin
- Inc( FmtStr, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}( S ) );
- Result := TRUE;
- end
- else
- Result := FALSE;
- end;
-
- function FmtIs( S1, S2: PKOLChar ): Boolean;
- begin
- Result := FmtIs1( S1 ) or FmtIs1( S2 );
- end;
-
- var ST: TSystemTime;
- begin
- FmtStr := PKOLChar( sFmtStr);
- S := PKOLChar( sS );
- FillChar( ST, Sizeof( ST ), #0 );
- h12 := FALSE;
- hAM := FALSE;
- while (FmtStr^ <> #0) and (S^ <> #0) do
- begin
- {$IFDEF UNICODE_CTRLS}
- if ((FmtStr^ >= 'a') and (FmtStr^ <= 'z') or
- (FmtStr^ >= 'A') and (FmtStr^ <= 'Z')) and
- (S^ >= '0') and (S^ <= '9') then
- {$ELSE}
- if (FmtStr^ in ['a'..'z','A'..'Z']) and (S^ in ['0'..'9']) then
- {$ENDIF}
- begin
- if FmtIs1( 'yyyy' ) then ST.wYear := GetNum( S, 4 )
- else if FmtIs1( 'yy' ) then ST.wYear := GetYear( S, 2 )
- else if FmtIs1( 'y' ) then ST.wYear := GetYear( S, -1 )
- else if FmtIs( 'dd', 'd' ) then ST.wDay := GetNum( S, 2 )
- else if FmtIs( 'MM', 'M' ) then ST.wMonth := GetNum( S, 2 )
- else if FmtIs( 'HH', 'H' ) then ST.wHour := GetNum( S, 2 )
- else if FmtIs( 'hh', 'h' ) then begin ST.wHour := GetNum( S, 2 ); h12 := TRUE end
- else if FmtIs( 'mm', 'm' ) then ST.wMinute := GetNum( S, 2 )
- else if FmtIs( 'ss', 's' ) then ST.wSecond := GetNum( S, 2 )
- else break; // + ECM
- end
- else
- {$IFDEF UNICODE_CTRLS}
- if (FmtStr^ = 'M') or (FmtStr^ = 'd') or (FmtStr^ = 'g') then
- {$ELSE}
- if (FmtStr^ in [ 'M', 'd', 'g' ]) then
- {$ENDIF}
- begin
- if FmtIs1( 'MMMM' ) then ST.wMonth := GetMonth( 'MMMM', S )
- else if FmtIs1( 'MMM' ) then ST.wMonth := GetMonth( 'MMM', S )
- else if FmtIs1( 'dddd' ) then SkipDayOfWeek( 'dddd', S )
- else if FmtIs1( 'ddd' ) then SkipDayOfWeek( 'ddd', S )
- else if FmtIs1( 'tt' ) then GetTimeMark( 'tt', S )
- else if FmtIs1( 't' ) then GetTimeMark( 't', S )
- else break; // + ECM
- end
- else
- begin
- if FmtStr^ = S^ then
- Inc( FmtStr );
- Inc( S );
- end;
- end;
-
- if h12 then
- if hAM then
- Inc( ST.wHour, 12 );
-
- SystemTime2DateTime( ST, Result );
- end;
-
- var FmtBuf: PKOLChar;
- DateSeparator : KOLChar = #0; // + ECM
-
- //[function Str2DateTimeShort]
- function Str2DateTimeShort( const S: String ): TDateTime;
- var FmtStr, FmtStr2: KOLString;
-
- function EnumDateFmt( lpstrFmt: PKOLChar ): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- GetMem( FmtBuf, {$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
- (( lpstrFmt ) + 1) * Sizeof( KOLChar ) );
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( FmtBuf, lpstrFmt );
- Result := FALSE;
- end;
-
- begin
- FmtStr := 'dd.MM.yyyy';
- FmtBuf := nil;
- EnumDateFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, DATE_SHORTDATE );
- if FmtBuf <> nil then
- begin
- FmtStr := FmtBuf;
- FreeMem( FmtBuf );
- end;
-
- FmtStr2 := 'H:mm:ss';
- FmtBuf := nil;
- EnumTimeFormats( @ EnumDateFmt, LOCALE_USER_DEFAULT, 0 );
- if FmtBuf <> nil then
- begin
- FmtStr2 := FmtBuf;
- FreeMem( FmtBuf );
- end;
-
- Result := Str2DateTimeFmt( FmtStr + ' ' + FmtStr2, S );
- end;
-
- // + ECM
- //[function Str2DateTimeShortEx]
- function Str2DateTimeShortEx( const S: KOLString ): TDateTime;
- var St: KOLString;
- Buff: Array[0..1] of KOLChar;
- begin
- if DateSeparator = #0 then
- begin
- if GetLocaleInfo({$ifdef wince}LOCALE_USER_DEFAULT{$else}GetThreadLocale{$endif},LOCALE_SDATE,Buff,2) > 0 then
- DateSeparator := Buff[0];
- end;
- St := S;
- if Pos(KOLString(DateSeparator),S) = 0 then
- St := '0.0.0 '+S;
- Result := Str2DateTimeShort(St);
- end;
-
- ///////////////////////////////////////////////////////////////////////
- // T H R E A D S
- ///////////////////////////////////////////////////////////////////////
-
- { -- Thread -- }
-
- //[function ThreadFunc]
- function ThreadFunc(Thread: PThread): integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result := Thread.Execute;
- end;
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewThread]
- function NewThread: PThread;
- begin
- new( Result, ThreadCreate );
- end;
- //[END NewThread]
- {$ELSE not_USE_CONSTRUCTORS}
- //*
- //[function NewThread]
- function NewThread: PThread;
- begin
- {$IFNDEF FPC105ORBELOW}
- IsMultiThread := True;
- {$ENDIF}
- {-}
- New( Result, Create );
- {+}
- {++}(*Result := PThread.Create;*){--}
- Result.FSuspended := True;
- {$IFDEF PSEUDO_THREADS}
- {$ELSE}
- Result.FHandle := CreateThread( nil, // no security
- 0, // the same stack size
- @ThreadFunc, // thread entry point
- Result, // parameter to pass to ThreadFunc
- CREATE_SUSPENDED, // always SUSPENDED
- Result.FThreadID ); // receive thread ID
- {$ENDIF}
- end;
- //[END NewThread]
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewThreadEx]
- function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
- begin
- new( Result, ThreadCreateEx( Proc ) );
- end;
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewThreadEx]
- {$IFDEF ASM_!VERSION}
- function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
- asm
- CALL NewThread
- POP EBP
- POP ECX
- POP EDX
- MOV [EAX].TThread.fOnExecute.TMethod.Code, EDX
- POP EDX
- MOV [EAX].TThread.fOnExecute.TMethod.Data, EDX
- PUSH ECX
- PUSH EAX
- CALL TThread.Resume
- POP EAX
- RET
- end;
- {$ELSE ASM_VERSION} //Pascal
- function NewThreadEx( const Proc: TOnThreadExecute ): PThread;
- begin
- Result := NewThread;
- Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;
- Result.Resume;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewThreadEx]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //[function NewThreadAutoFree]
- function NewThreadAutoFree( const Proc: TOnThreadExecute ): PThread;
- begin
- Result := NewThread;
- Result.OnExecute := {++}(*{$IFDEF F_P} @ {$ENDIF}*){--}Proc;
- Result.F_AutoFree := TRUE;
- if Assigned( Proc ) then
- Result.Resume;
- end;
-
- { TThread }
-
- function WndProcCMExec( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var Thread: PThread;
- begin
- Result := FALSE;
- if Msg.message = CM_EXECPROC then
- begin
- //Global_Synchronized( Pointer( Msg.lParam ), Pointer( Msg.wParam ) );
- Thread := PThread( Msg.lParam );
- if Msg.wParam <> 0 then
- Thread.FMethodEx( Thread, Pointer( Msg.wParam ) )
- else
- Thread.FMethod( );
- Rslt := 0;
- end;
- end;
-
- {$IFDEF PSEUDO_THREADS}
- function timeBeginPeriod(uPeriod: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'winmm.dll' name 'timeBeginPeriod';
- function timeEndPeriod(uPeriod: UINT): UINT; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'winmm.dll' name 'timeEndPeriod';
- {$ENDIF}
-
- procedure TThread.Init;
- begin
- {$IFDEF _D2orD3}
- inherited;
- {$ENDIF}
- if Applet <> nil then
- Applet.AttachProc( WndProcCMExec );
- {$IFDEF PSEUDO_THREADS}
- if (MainThread = nil) and not CreatingMainThread then
- begin // creating main thread
- CreatingMainThread := TRUE;
- new( MainThread, Create );
- CreatingMainThread := FALSE;
- end;
- if CreatingMainThread then
- begin
- MainThread := @ Self;
- {MainThread.}AllThreads := NewList;
- {MainThread.}CurrentThread := MainThread;
- TimeBeginPeriod( 10 );
- end;
- if not CreatingMainThread and (MainThread <> @ Self) then
- begin // creating other threads
- GetMem( StackBottom, PseudoThreadStackSize );
- CurStackPos := Pointer( DWORD( StackBottom ) + PseudoThreadStackSize );
- Stack_Empty := TRUE;
- end;
- MainThread.AllThreads.Add( @ Self );
- {$ENDIF}
- end;
-
- //[destructor TThread.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TThread.Destroy;
- begin
- RefInc;
- if not FTerminated then
- begin
- Terminate;
- WaitFor;
- end;
- if (FHandle <> 0) then
- CloseHandle(FHandle);
- {$IFDEF PSEUDO_THREADS}
- if StackBottom <> nil then
- FreeMem( StackBottom );
- if MainThread = @ Self then
- begin
- TimeEndPeriod( 10 );
- AllThreads.Free;
- end
- else
- if MainThread <> nil then
- begin
- MainThread.AllThreads.Remove( @ Self );
- if MainThread.AllThreads.Count <= 1 then
- Free_And_Nil( MainThread );
- end;
- {$ENDIF}
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TThread.Execute]
- function TThread.Execute: integer;
- begin
- Result := 0;
- if Assigned( FOnExecute ) then
- Result := FOnExecute( @Self );
- FResult := Result;
- FTerminated := TRUE; // fake thread object (to prevent terminating while freeing)
- if F_AutoFree then
- Free;
- end;
-
- //*
- //[function TThread.GetPriorityCls]
- function TThread.GetPriorityCls: Integer;
- begin
- {$IFDEF PSEUDO_THREADS}
- Result := FPrtyCls;
- {$ELSE}
- Result := {$ifdef wince} NORMAL_PRIORITY_CLASS {$else} GetPriorityClass(FHandle) {$endif};
- {$ENDIF}
- end;
-
- //*
- //[function TThread.GetThrdPriority]
- function TThread.GetThrdPriority: Integer;
- begin
- {$IFDEF PSEUDO_THREADS}
- Result := FPriority;
- {$ELSE}
- Result := GetThreadPriority(FHandle);
- {$ENDIF}
- end;
-
- //*
- //[procedure TThread.Resume]
- procedure TThread.Resume;
- begin
- {$IFDEF PSEUDO_THREADS}
- if MainThread.CurrentThread = @ Self then
- Exit;
- MainThread.SwitchToThread( @ Self );
- {$ELSE}
- FSuspended := False;
- if (ResumeThread(FHandle) > 1) then
- FSuspended := True
- else
- if Assigned(FOnResume) then
- FOnResume(@Self);
- {$ENDIF}
- end;
-
- //*
- //[procedure TThread.SetPriorityCls]
- procedure TThread.SetPriorityCls(Value: Integer);
- begin
- {$ifdef win32}
- {$IFDEF DEBUG}
- if not SetPriorityClass(GetCurrentProcess, Value) then
- begin
- ShowMessage( SysErrorMessage( GetLastError ) );
- end;
- {$ELSE}
- {$IFDEF PSEUDO_THREADS}
- FPrtyCls := Value;
- {$ELSE}
- SetPriorityClass(GetCurrentProcess, Value);
- {$ENDIF}
- {$ENDIF}
- {$endif win32}
- end;
-
- //*
- //[procedure TThread.SetThrdPriority]
- procedure TThread.SetThrdPriority(Value: Integer);
- begin
- FPriority := Value;
- {$IFDEF PSEUDO_THREADS}
- {$ELSE}
- SetThreadPriority(FHandle, Value);
- {$ENDIF}
- end;
-
- //*
- //[procedure TThread.Suspend]
- procedure TThread.Suspend;
- begin
- {$IFDEF PSEUDO_THREADS}
- if MainThread <> @ Self then
- FSuspended := TRUE;
- if MainThread.CurrentThread = @ Self then
- MainThread.NextThread;
- {$ELSE}
- FSuspended := TRUE;
- if Assigned(FOnSuspend) then
- Synchronize( FOnSuspend );
- SuspendThread(FHandle);
- {$ENDIF}
- end;
-
- {$IFDEF PSEUDO_THREADS}
- procedure FinishThread;
- begin
- MainThread.CurrentThread.fTerminated := TRUE;
- MainThread.CurrentThread.Stack_Empty := TRUE;
- MainThread.NextThread;
- end;
-
- procedure TThread.SwitchToThread(T: PThread);
- begin
- if (T <> MainThread) and not Assigned( T.OnExecute ) then Exit;
- if Assigned( MainThread.CurrentThread.OnSuspend ) then
- begin
- MainThread.CurrentThread.OnExecute( MainThread.CurrentThread );
- end;
- asm
- mov edx, [T]
- // 1. Suspending current thread
- mov ecx, [MainThread]
- mov eax, [ecx].CurrentThread
- push ebx
- push ebp
- push esi
- push edi
- mov [eax].CurStackPos, esp
- mov [eax].Stack_Empty, 0
- // 2. Switching to another thread
-
- mov [ecx].CurrentThread, edx
-
- cmp [edx].Stack_Empty, 0
- jz @@1
- // the first call
- mov [edx].Stack_Empty, 0
- cmp [edx].FSuspended, 0
- jz @@0
- mov [edx].FSuspended, 0
-
- mov esp, [edx].CurStackPos
- mov ecx, [edx].fOnResume.TMethod.Code
- jecxz @@0
- mov eax, [edx].fOnResume.TMethod.Data
- call ecx // calling OnResume for resuming thread
- @@0:
- mov eax, [edx].fOnExecute.TMethod.Data
- mov ecx, [edx].fOnExecute.TMethod.Code
- push offset [FinishThread] // if thread will be finished it will jump there
- jmp ecx
- @@1:
- // other calls - resuming
- mov esp, [edx].CurStackPos
- pop edi
- pop esi
- pop ebp
- pop ebx
- cmp [edx].FSuspended, 0
- jz @@2
- mov [edx].FSuspended, 0
-
- mov ecx, [edx].fOnResume.TMethod.Code
- jecxz @@2
- mov eax, [edx].fOnResume.TMethod.Data
- call ecx // calling OnResume for resuming thread
- @@2:
- end;
- // At this point, thread is resumed
- end;
-
- procedure TThread.NextThread;
- var i: Integer;
- T: PThread;
- C: DWORD;
- begin
- i := MainThread.AllThreads.IndexOf( MainThread.CurrentThread );
- if i >= 0 then
- begin
- C := GetTickCount;
- while TRUE do
- begin
- inc( i );
- if i >= MainThread.AllThreads.Count then i := 0;
- T := MainThread.AllThreads.Items[ i ];
- if (T.DoNotWakeUntil > C) and (T <> MainThread) then continue;
- if (T = MainThread) and (MainThread.CurrentThread = T) then Exit;
- if not T.Terminated and not ((T <> MainThread) and (T.Suspended)) then break;
- end;
- MainThread.SwitchToThread( MainThread.AllThreads.Items[ i ] );
- end;
- end;
-
- procedure Sleep( n: DWORD );
- begin
- if Assigned( MainThread ) then
- begin
- MainThread.CurrentThread.DoNotWakeUntil := GetTickCount + n;
- MainThread.NextThread;
- end
- else
- if n > 0 then Windows.Sleep( n );
- end;
-
- function WaitForMultipleObjects( nCount: DWORD;
- lpHandles: PHandle; fWaitAll: BOOL; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var i: Integer;
- w: DWORD;
- Ph: PHandle;
- Limit: DWORD;
- begin
- if dwMilliseconds = INFINITE then
- Limit := INFINITE
- else
- Limit := GetTickCount + dwMilliseconds;
- while TRUE do
- begin
- Ph := lpHandles;
- w := 0;
- for i := 0 to nCount-1 do
- begin
- if Windows.WaitForSingleObject( Ph^, 0 ) = WAIT_OBJECT_0 then
- begin
- inc( w );
- if not fWaitAll then
- begin
- Result := WAIT_OBJECT_0 + i;
- Exit;
- end;
- end;
- inc( Ph );
- end;
- if w = nCount then
- begin
- Result := WAIT_OBJECT_0;
- Exit;
- end;
- if (Limit <> INFINITE) and (GetTickCount > Limit) then
- begin
- Result := WAIT_TIMEOUT;
- Exit;
- end;
- if Assigned( MainThread ) then
- MainThread.NextThread;
- {$IFDEF WAIT_SLEEP}
- Sleep( 10 );
- {$ENDIF}
- end;
- end;
-
- function WaitForSingleObject( hHandle: THandle; dwMilliseconds: DWORD ): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result := WaitForMultipleObjects( 1, @ hHandle, TRUE, dwMilliseconds );
- end;
- {$ENDIF PSEUDO_THREADS}
-
- //*
- //[procedure TThread.Synchronize]
- procedure TThread.Synchronize(Method: TThreadMethod);
- begin
- {$IFDEF PSEUDO_THREADS}
- Method;
- {$ELSE}
- FMethod := Method;
- if Applet <> nil then
- SendMessage( Applet.fHandle, CM_EXECPROC, 0, Integer( @Self ) );
- {$ENDIF}
- end;
-
- //[procedure TThread.SynchronizeEx]
- procedure TThread.SynchronizeEx( Method: TThreadMethodEx; Param: Pointer );
- begin
- Assert( Param <> nil, 'Parameter must not be NIL' );
- {$IFDEF PSEUDO_THREADS}
- Method( TMethod( Method ).Data, Param );
- {$ELSE}
- FMethodEx := Method;
- SendMessage( Applet.fHandle, CM_EXECPROC, Integer( Param ), Integer( @Self ) );
- {$ENDIF}
- end;
-
- //*
- //[procedure TThread.Terminate]
- procedure TThread.Terminate;
- begin
- {$IFDEF PSEUDO_THREADS}
- FTerminated := TRUE;
- if Assigned( MainThread ) then
- if MainThread.CurrentThread = @ Self then
- MainThread.NextThread;
- {$ELSE}
- TerminateThread(FHandle,0);
- FTerminated := True;
- {$ENDIF}
- end;
-
- //*
- //[function TThread.WaitFor]
- function TThread.WaitFor: Integer;
- begin
- RefInc;
- Result := -1;
- {$IFDEF PSEUDO_THREADS}
- while not Terminated do
- Resume;
- if Terminated then
- Result := FResult;
- {$ELSE}
- if FHandle = 0 then Exit;
- WaitForSingleObject(FHandle, INFINITE);
- GetExitCodeThread(FHandle, DWORD(Result));
- {$ENDIF}
- RefDec;
- end;
-
- function TThread.WaitForTime(T: DWORD): Integer;
- {$IFDEF PSEUDO_THREADS}
- var LimitTime: DWORD;
- {$ENDIF}
- begin
- {$IFDEF PSEUDO_THREADS}
- LimitTime := GetTickCount + T;
- RefInc;
- while not Terminated and (GetTickCount < LimitTime) do
- Resume;
- Result := -1;
- if Terminated then
- Result := FResult;
- RefDec;
- {$ELSE}
- Result := WAIT_OBJECT_0;
- RefInc;
- if FHandle = 0 then Exit;
- Result := WaitForSingleObject(FHandle, T);
- if Result = WAIT_OBJECT_0 then
- GetExitCodeThread(FHandle, T);
- RefDec;
- {$ENDIF}
- end;
-
- {$IFDEF _D2}
- {$DEFINE _D2orFPC}
- {$ENDIF}
- {$IFDEF _FPC}
- {$IFNDEF _D2orFPC}
- {$DEFINE _D2orFPC}
- {$ENDIF}
- {$ENDIF}
-
- function TThread.GetPriorityBoost: Boolean;
- type TGetPriorityBoost = function(hThread: THandle;
- var DisablePriorityBoost: Bool): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var B: Bool;
- GPB: TGetPriorityBoost;
- M: THandle;
- begin
- Result := TRUE;
- if fHandle = 0 then Exit;
- if (WinVer >= WvNT) then // by TK: only evaluate if this is true, regardless of evaluation settings
- begin
- M := GetModuleHandle( 'kernel32' );
- GPB := GetProcAddress( M, 'GetThreadPriorityBoost' );
- if Assigned( GPB ) then
- if GPB( fHandle, B ) then
- Result := B;
- end;
- end;
-
- procedure TThread.SetPriorityBoost(const Value: Boolean);
- type TSetPriorityBoost = function(hThread: THandle;
- DisablePriorityBoost: Bool): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var M: THandle;
- SPB: TSetPriorityBoost;
- begin
- if fHandle = 0 then Exit;
- if WinVer >= WvNT then
- begin
- M := GetModuleHandle( 'kernel32' );
- SPB := GetProcAddress( M, 'SetThreadPriorityBoost' );
- if Assigned( SPB ) then
- SPB( fHandle, not Value );
- end;
- end;
-
- { TStream }
-
- {* This part of the unit contains implementation of streams for KOL. Please note,
- that both stream types (file stream and memory stream) are incapsulated
- by a single object type TStream. To avoid including unnedeed code,
- use constructing functions NewReadFileStream and NewWriteFileStream
- to work with file streams, which do not require both types of operation. }
-
- {* To create new type of stream, define your own methods, and in your
- constructing function, pass it to _NewStream function (through
- TStreamMethods record). In a field Custom, You can store a reference to
- your own data of any type (but do not forget to define correct releasing
- of such data in your fClose procedure). }
-
- //[function TStream.GetPosition]
- function TStream.GetPosition: DWord;
- begin
- Result := Seek( 0, spCurrent );
- end;
-
- //[procedure TStream.SetPosition]
- procedure TStream.SetPosition(Value: DWord);
- begin
- Seek( Value, spBegin );
- end;
-
- //[function TStream.GetSize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStream.GetSize: DWord;
- begin
- Result := fMethods.fGetSiz( @Self );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStream.SetSize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStream.SetSize(NewSize: DWord);
- begin
- fMethods.fSetSiz( @Self, NewSize );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStream.GetFileStreamHandle]
- function TStream.GetFileStreamHandle: THandle;
- begin
- Result := fData.fHandle;
- end;
-
- //[function TStream.Read]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStream.Read(var Buffer; Count: DWord): DWord;
- begin
- Result := fMethods.fRead( @Self, Buffer, Count );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStream.GetCapacity]
- function TStream.GetCapacity: DWORD;
- begin
- Result := fData.fCapacity;
- end;
-
- //[procedure TStream.SetCapacity]
- procedure TStream.SetCapacity(Value: DWORD);
- var OldSize: DWORD;
- begin
- {$IFDEF OLD_STREAM_CAPACITY}
- if fData.fCapacity >= Value then Exit;
- OldSize := Size;
- Size := Value;
- Size := OldSize;
- {$ELSE}
- if Value < fData.fSize then Value := fData.fSize;
- if Value > fData.fCapacity then
- begin
- OldSize := Size;
- Size := Value;
- Size := OldSize;
- end
- else
- if fMemory <> nil then
- begin
- {$IFDEF _D4orHigher}
- fMemory := ReallocMemory( fMemory, Value );
- {$ELSE}
- ReallocMem( fMemory, Value );
- {$ENDIF}
- fData.fCapacity := Value;
- end;
- {$ENDIF}
- end;
-
- //[function TStream.Busy]
- function TStream.Busy: Boolean;
- begin
- Result := Assigned( fData.fThread );
- end;
-
- //[function TStream.DoAsyncRead]
- function TStream.DoAsyncRead( Sender: PThread ): Integer;
- begin
- Read( Pointer( fParam1 )^, fParam2 );
- fData.fThread := nil;
- Result := 0;
- end;
-
- //[procedure TStream.ReadAsync]
- procedure TStream.ReadAsync(var Buffer; Count: DWord);
- begin
- if Busy then Wait;
- fData.fThread := NewThreadAutoFree( nil );
- fData.fThread.OnExecute := DoAsyncRead;
- fParam1 := DWORD( @ Buffer );
- fParam2 := Count;
- fData.fThread.Resume;
- end;
-
- //[function TStream.DoAsyncSeek]
- function TStream.DoAsyncSeek( Sender: PThread ): Integer;
- begin
- Seek( fParam1, TMoveMethod( fParam2 ) );
- fData.fThread := nil;
- Result := 0;
- end;
-
- //[procedure TStream.SeekAsync]
- procedure TStream.SeekAsync(MoveTo: Integer; MoveMethod: TMoveMethod);
- begin
- if Busy then Wait;
- fData.fThread := NewThreadAutoFree( nil );
- fData.fThread.OnExecute := DoAsyncSeek;
- fParam1 := MoveTo;
- fParam2 := Ord( MoveMethod );
- fData.fThread.Resume;
- end;
-
- //[function TStream.DoAsyncWrite]
- function TStream.DoAsyncWrite( Sender: PThread ): Integer;
- begin
- Write( Pointer( fParam1 )^, fParam2 );
- fData.fThread := nil;
- Result := 0;
- end;
-
- //[procedure TStream.WriteAsync]
- procedure TStream.WriteAsync(var Buffer; Count: DWord);
- begin
- if Busy then Wait;
- fData.fThread := NewThreadAutoFree( nil );
- fData.fThread.OnExecute := DoAsyncWrite;
- fParam1 := DWORD( @ Buffer );
- fParam2 := Count;
- fData.fThread.Resume;
- end;
-
- //[procedure TStream.Wait]
- procedure TStream.Wait;
- begin
- if not Assigned( fData.fThread ) then Exit;
- if Assigned( fMethods.fWait ) then
- fMethods.fWait( @Self )
- else
- fData.fThread.WaitFor;
- end;
-
- //[function TStream.Write]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStream.Write(var Buffer; Count: DWord): DWord;
- begin
- Result := fMethods.fWrite( @Self, Buffer, Count );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStream.WriteVal]
- function TStream.WriteVal(Value, Count: DWORD): DWORD;
- begin
- Result := Write( Value, Count );
- end;
-
- //[function TStream.WriteStr]
- function TStream.WriteStr(S: String): DWORD;
- begin
- if S <> '' then
- Result := fMethods.fWrite( @Self, S[1], Length( S ) )
- else
- Result := 0;
- end;
-
- //[function TStream.ReadStrZ]
- function TStream.ReadStrZ: String;
- var C: Char;
- begin
- Result := '';
- REPEAT
- C := #0;
- Read( C, 1 );
- if C <> #0 then Result := Result + C;
- UNTIL C = #0;
- end;
-
- {$IFDEF _D3orHigher}
- function TStream.ReadWStrZ: WideString;
- var C: WideChar;
- begin
- Result := '';
- REPEAT
- C := #0;
- Read( C, 2 );
- if C <> #0 then
- Result := Result +
- {$IFDEF _D3}
- WideString( C )
- {$ELSE}
- C
- {$ENDIF};
- UNTIL C = #0;
- end;
- {$ENDIF _D3orHigher}
-
- //[function TStream.ReadStr]
- function TStream.ReadStr: String;
- var C: Char;
- begin
- Result := '';
- REPEAT
- C := #0;
- Read( C, 1 );
- if C <> #0 then
- begin
- if C = #13 then
- begin
- C := #0;
- Read( C, 1 );
- if C <> #10 then Position := Position - 1;
- C := #13;
- end
- else
- if C = #10 then
- C := #13;
- if C <> #13 then
- Result := Result + C;
- end;
- UNTIL C in [ #13, #0 ];
- end;
-
- //[function TStream.ReadStrLen]
- function TStream.ReadStrLen(Len: Integer): String;
- var i: Integer;
- begin
- SetLength( Result, Len );
- i := Read( Result[1], Len );
- SetLength( Result, i );
- end;
-
- //[function TStream.WriteStrZ]
- function TStream.WriteStrZ(S: String): DWORD;
- var C: Char;
- begin
- if S = '' then
- begin
- C := #0;
- Result := Write( C, 1 );
- end
- else
- Result := Write( S[ 1 ], Length( S ) + 1 );
- end;
-
- {$IFDEF _D3orHigher}
- function TStream.WriteWStrZ(S: WideString): DWORD;
- var C: WideChar;
- begin
- if S = '' then
- begin
- C := #0;
- Result := Write( C, 2 );
- end
- else
- Result := Write( S[ 1 ], (Length( S ) + 1) * 2 );
- end;
- {$ENDIF _D3orHigher}
-
- //[function TStream.WriteStrEx]
- function TStream.WriteStrEx(S: String): DWord;
- var L: DWORD;
- begin
- L := length(s);
- result:=fmethods.fwrite(@self,L,Sizeof(DWORD));
- if result = Sizeof(DWORD) then
- Inc( result, fmethods.fwrite(@self,s[1],L) );
- end;
-
- //[function TStream.ReadStrExVar]
- function TStream.ReadStrExVar(var S: String): DWord;
- begin
- fmethods.fread(@self,result,Sizeof(DWORD));
- setlength(s,result);
- if result<>0 then result:=fmethods.fread(@self,s[1],result);
- end;
-
- //[function TStream.ReadStrEx]
- function TStream.ReadStrEx: String;
- begin
- readstrexvar(result);
- end;
-
- //[function TStream.WriteStrPas]
- function TStream.WriteStrPas( S: String ): DWORD;
- var L: Integer;
- begin
- Result := 0;
- L := Length( S );
- if L > 255 then L := 255;
- if Write( L, 1 ) < 1 then Exit;
- Result := 1;
- if L > 0 then
- Result := Write( S[ 1 ], L ) + 1;
- end;
-
- //[function TStream.ReadStrPas]
- function TStream.ReadStrPas: String;
- var L: Byte;
- begin
- Result := '';
- if Read( L, 1 ) < 1 then Exit;
- SetLength( Result, L );
- L := Read( Result[ 1 ], L );
- Result := Copy( Result, 1, L );
- end;
-
- //[function TStream.Seek]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStream.Seek(MoveTo: integer; MoveMethod: TMoveMethod): DWord;
- begin
- Result := fMethods.fSeek( @Self, MoveTo, MoveMethod );
- end;
- {$ENDIF ASM_VERSION}
-
- //[destructor TStream.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TStream.Destroy;
- begin
- fMethods.fClose( @Self );
- fData.fThread.Free;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- procedure TStream.SaveToFile(const Filename: KOLString; Start, CountSave: DWORD);
- var F: PStream;
- SavePos: DWORD;
- begin
- F := NewWriteFileStream( Filename );
- SavePos := Position;
- Position := Start;
- Stream2Stream( F, @ Self, CountSave );
- Position := SavePos;
- F.Free;
- end;
-
- //+-
- //[function _NewStream]
- function _NewStream( const StreamMethods: TStreamMethods ): PStream;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PStream.Create;*){--}
- Move( StreamMethods, Result.fMethods, Sizeof( TStreamMethods ) );
- Result.fPMethods := @Result.fMethods;
- end;
-
- //+
- //[function SeekFileStream]
- function SeekFileStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
- begin
- Result := FileSeek( Strm.fData.fHandle, MoveTo, MoveFrom );
- {$IFDEF FILESTREAM_POSITION}
- Strm.fData.fPosition := Result;
- {$ENDIF}
- end;
-
- //+
- //[function GetSizeFileStream]
- function GetSizeFileStream( Strm: PStream ): DWORD;
- begin
- Result := GetFileSize( Strm.fData.fHandle, nil );
- if Result = DWORD( -1 ) then Result := 0;
- end;
-
- //[procedure DummySetSize]
- procedure DummySetSize( Strm: PStream; Value: DWORD );
- begin
- end;
-
- //[procedure DummyStreamProc]
- procedure DummyStreamProc(Strm: PStream);
- begin
- end;
-
- //[function DummyReadWrite]
- function DummyReadWrite( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- {$ifdef cpu86}
- asm
- XOR EAX, EAX
- {$else}
- begin
- Result:=0;
- {$endif cpu86}
- end;
-
- //[function ReadFileStream]
- function ReadFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- begin
- Result := FileRead( Strm.fData.fHandle, Buffer, Count );
- {$IFDEF FILESTREAM_POSITION}
- inc( Strm.fData.fPosition, Result );
- {$ENDIF}
- end;
-
- //[function WriteFileStream]
- function WriteFileStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- begin
- Result := FileWrite( Strm.fData.fHandle, Buffer, Count );
- {$IFDEF FILESTREAM_POSITION}
- inc( Strm.fData.fPosition, Result );
- {$ENDIF}
- end;
-
- //[FUNCTION WriteFileStreamEOF]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WriteFileStreamEOF( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- begin
- Result := WriteFileStream( Strm, Buffer, Count );
- SetEndOfFile( Strm.fData.fHandle );
- end;
- {$ENDIF ASM_VERSION}
- //[END WriteFileStreamEOF]
-
- //[procedure CloseFileStream]
- procedure CloseFileStream( Strm: PStream );
- begin
- FileClose( Strm.fData.fHandle );
- end;
-
- //[FUNCTION SeekMemStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function SeekMemStream( Strm: PStream; MoveTo: Integer; MoveFrom: TMoveMethod ): DWORD;
- var NewPos: DWORD;
- begin
- case MoveFrom of
- spBegin: NewPos := MoveTo;
- spCurrent: NewPos := Strm.fData.fPosition + DWORD( MoveTo );
- else //spEnd:
- NewPos := Strm.fData.fSize + DWORD( MoveTo );
- end;
- if NewPos > Strm.fData.fSize then
- Strm.SetSize( NewPos );
- Strm.fData.fPosition := NewPos;
- Result := NewPos;
- end;
- {$ENDIF ASM_VERSION}
- //[END SeekMemStream]
-
- //[function GetSizeMemStream]
- function GetSizeMemStream( Strm: PStream ): DWORD;
- begin
- Result := Strm.fData.fSize;
- end;
-
- //[PROCEDURE SetSizeMemStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure SetSizeMemStream( Strm: PStream; NewSize: DWORD );
- var S: PStream;
- NewCapacity: DWORD;
- begin
- S := Strm;
- if S.fData.fCapacity < NewSize then
- begin
- {$IFDEF OLD_MEMSTREAMS_SETSIZE}
- NewCapacity := (NewSize or CapacityMask) + 1;
- {$ELSE}
- NewCapacity := NewSize;
- {$ENDIF}
- if S.fMemory = nil then
- begin
- if NewSize <> 0 then
- GetMem( S.fMemory, NewCapacity );
- end
- else
- ReallocMem( S.fMemory, NewCapacity );
- S.fData.fCapacity := NewCapacity;
- end
- else
- if NewSize = 0 then
- begin
- FreeMem( S.fMemory );
- S.fMemory := nil;
- S.fData.fCapacity := 0;
- end;
- S.fData.fSize := NewSize;
- if S.fData.fPosition > S.fData.fSize then
- S.fData.fPosition := S.fData.fSize;
- end;
- {$ENDIF ASM_VERSION}
- //[END SetSizeMemStream]
-
- //[FUNCTION ReadMemStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function ReadMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- var S: PStream;
- begin
- S := Strm;
- if Count + S.fData.fPosition > S.fData.fSize then
- Count := S.fData.fSize - S.fData.fPosition;
- Result := Count;
- Move( Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Buffer, Result );
- Inc( S.fData.fPosition, Result );
- end;
- {$ENDIF ASM_VERSION}
- //[END ReadMemStream]
-
- //[FUNCTION WriteMemStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WriteMemStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- var S: PStream;
- begin
- S := Strm;
- if Count + S.fData.fPosition > S.fData.fSize then
- S.SetSize( S.fData.fPosition + Count );
- Result := Count;
- Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
- Inc( S.fData.fPosition, Result );
- end;
- {$ENDIF ASM_VERSION}
- //[END WriteMemStream]
-
- //[PROCEDURE CloseMemStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure CloseMemStream( Strm: PStream );
- var S: PStream;
- begin
- S := Strm;
- if S.fMemory <> nil then
- FreeMem( S.fMemory );
- end;
- {$ENDIF ASM_VERSION}
- //[END CloseMemStream]
-
- procedure DummyCloseStream( Strm: PStream );
- begin
- // nothing here
- end;
-
- // by Roman Vorobets:
- //[procedure SetSizeFileStream]
- procedure SetSizeFileStream( Strm: PStream; NewSize: DWORD );
- var
- P: DWORD;
- begin
- P:=Strm.Position;
- Strm.Position:=NewSize;
- SetEndOfFile(Strm.Handle);
- if P < NewSize then
- Strm.Position:=P;
- end;
-
- //[function NewFileStream]
- function NewFileStream( const FileName: KOLString; Options: DWORD ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fMethods.fWrite := WriteFileStream; // not WriteStreamEOF, Lëåêñåé +óâàëîâ
- Result.fMethods.fSetSiz := SetSizeFileStream;
- Result.fData.fHandle := FileCreate( FileName, Options );
- end;
-
- //[FUNCTION NewReadFileStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewReadFileStream( const FileName: KOLString ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fData.fHandle := FileCreate( FileName,
- ofOpenRead or ofShareDenyWrite or ofOpenExisting );
- end;
- {$ENDIF ASM_VERSION}
- //[END NewReadFileStream]
-
- function NewExFileStream( F: HFile ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fMethods.fWrite := WriteFileStream;
- Result.fData.fHandle := F;
- Result.fMethods.fClose := DummyCloseStream;
- end;
-
- {$IFDEF _D3orHigher}
- function NewReadFileStreamW( const FileName: WideString ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fData.fHandle := WFileCreate( FileName,
- ofOpenRead or ofShareDenyWrite or ofOpenExisting );
- end;
- {$ENDIF _D3orHigher}
-
- //[FUNCTION NewWriteFileStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewWriteFileStream( const FileName: KOLString ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fWrite := WriteFileStreamEOF;
- Result.fMethods.fSetSiz := SetSizeFileStream;
- Result.fData.fHandle := FileCreate( FileName,
- ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
- end;
- {$ENDIF ASM_VERSION}
- //[END NewWriteFileStream]
-
- {$IFDEF _D3orHigher}
- function NewWriteFileStreamW( const FileName: WideString ): PStream;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fWrite := WriteFileStreamEOF;
- Result.fMethods.fSetSiz := SetSizeFileStream;
- Result.fData.fHandle := WFileCreate( FileName,
- ofOpenWrite or ofCreateAlways or ofShareDenyWrite );
- end;
- {$ENDIF _D3orHigher}
-
- //[FUNCTION NewReadWriteFileStream]
- {$IFDEF ASM_noVERSION}
- function NewReadWriteFileStream( const FileName: String ): PStream;
- asm
- PUSH EBX
- XCHG EBX, EAX
- MOV EAX, offset[BaseFileMethods]
- CALL _NewStream
- MOV EDX, [ReadFileStreamProc]
- MOV [EAX].TStream.fMethods.fRead, EDX
- MOV [EAX].TStream.fMethods.fWrite, offset[WriteFileStream]
- MOV [EAX].TStream.fMethods.fSetSiz, offset[SetSizeFileStream]
- XCHG EBX, EAX
-
- PUSH EAX
- CALL FileExists
- MOV EDX, ofOpenReadWrite or ofCreateAlways or ofShareDenyWrite
- ADD DH, AL // $200 (ofCreateAlways) -> $300 (ofCreateExisting)
- POP EAX
-
- CALL FileCreate
- MOV [EBX].TStream.fData.fHandle, EAX
- XCHG EAX, EBX
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function NewReadWriteFileStream( const FileName: KOLString ): PStream;
- var Creation: DWORD;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fMethods.fWrite := WriteFileStream;
- Result.fMethods.fSetSiz := SetSizeFileStream;
- Creation := ofCreateAlways;
- if FileExists( FileName ) then Creation := ofOpenExisting;
- Result.fData.fHandle := FileCreate( FileName,
- ofOpenReadWrite or Creation or ofShareDenyWrite );
- end;
- {$ENDIF ASM_VERSION}
- //[END NewReadWriteFileStream]
-
- {$IFDEF _D3orHigher}
- function NewReadWriteFileStreamW( const FileName: WideString ): PStream;
- var Creation: DWORD;
- begin
- Result := _NewStream( BaseFileMethods );
- Result.fMethods.fRead := ReadFileStreamProc;
- Result.fMethods.fWrite := WriteFileStream;
- Result.fMethods.fSetSiz := SetSizeFileStream;
- Creation := ofCreateAlways;
- if WFileExists( FileName ) then Creation := ofOpenExisting;
- Result.fData.fHandle := WFileCreate( FileName,
- ofOpenReadWrite or Creation or ofShareDenyWrite );
- end;
- {$ENDIF _D3orHigher}
-
- //[function NewMemoryStream]
- function NewMemoryStream: PStream;
- begin
- Result := _NewStream( MemoryMethods );
- end;
-
- //[FUNCTION WriteExMemoryStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function WriteExMemoryStream( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
- var S: PStream;
- begin
- S := Strm;
- if Count + S.fData.fPosition > S.fData.fSize then
- Count := S.fData.fSize - S.fData.fPosition;
- Result := Count;
- Move( Buffer, Pointer( DWORD(S.fMemory) + S.fData.fPosition )^, Result );
- Inc( S.fData.fPosition, Result );
- end;
- {$ENDIF ASM_VERSION}
- //[END WriteExMemoryStream]
-
- //[procedure DummyClose_ExMemStream]
- procedure DummyClose_ExMemStream( Strm: PStream );
- begin
- // nothing to do - ignore call (memory is not released by any way)
- end;
-
- //[function NewExMemoryStream]
- function NewExMemoryStream( ExistingMem: Pointer; Size: DWORD ): PStream;
- begin
- Result := NewMemoryStream;
- Result.fMemory := ExistingMem;
- Result.fData.fCapacity := Size;
- Result.fData.fSize := Size;
- Result.fMethods.fWrite := WriteExMemoryStream;
- Result.fMethods.fSetSiz := DummySetSize;
- Result.fMethods.fClose := DummyClose_ExMemStream;
- end;
-
- //*
- //[function Stream2Stream]
- function Stream2Stream( Dst, Src: PStream; Count: DWORD ): DWORD;
- var Buf: Pointer;
- begin
- if Src.fMemory <> nil then
- begin
- if Src.fData.fPosition + Count > Src.fData.fSize then
- Count := Src.fData.fSize - Src.fData.fPosition;
- Result := Dst.Write( Pointer(DWORD(Src.fMemory)+Src.fData.fPosition)^,
- Count );
- Inc( Src.fData.fPosition, Result );
- end
- else
- if Dst.fMemory <> nil then
- begin
- if Dst.fData.fPosition + Count > Dst.fData.fSize then
- Dst.SetSize( Dst.fData.fPosition + Count );
- Result := Src.Read( Pointer( DWORD( Dst.fMemory ) + Dst.fData.fPosition )^,
- Count );
- Inc( Dst.fData.fPosition, Result );
- end
- else
- begin
- GetMem( Buf, Count );
- Count := Src.Read( Buf^, Count );
- Result := Dst.Write( Buf^, Count );
- FreeMem( Buf );
- end;
- end;
-
- //[function Stream2StreamEx]
- function Stream2StreamEx( Dst, Src: PStream; Count: DWORD ): DWORD;
- begin
- Result := Stream2StreamExBufSz( Dst, Src, Count, 65536 );
- end;
-
- //[function Stream2StreamExBufSz]
- function Stream2StreamExBufSz( Dst, Src: PStream; Count, BufSz: DWORD ): DWORD;
- var
- buf:pointer;
- rd, wr:dword;
- begin
- if count=0 then result:=0 else
- begin
- result:=0;
- BufSz := Min( BufSz, Count );
- if BufSz = 0 then BufSz := Count;
- getmem(buf,BufSz);
- repeat
- if count<BufSz then rd:=count else rd:=BufSz;
- rd:=src.read(buf^,rd);
- wr := dst.write(buf^,rd);
- inc(result,wr);
- dec(Count, rd);
- until (rd<>BufSz) or (Count=0);
- freemem(buf);
- end;
- end;
-
- //[FUNCTION Resource2Stream]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function Resource2Stream( DestStrm : PStream; Inst : HInst;
- ResName : PKOLChar; ResType : PKOLChar ): Integer;
- var R : HRSRC;
- G : HGlobal;
- P : PChar;
- Sz : DWORD;
- E : Integer;
- begin
- Result := 0;
- R := FindResource( Inst, ResName, ResType );
- if R <> 0 then
- begin
- Sz := SizeofResource( Inst, R );
- G := LoadResource( Inst, R );
- if G <> 0 then
- begin
- P := GlobalLock( G );
- if P = nil then
- begin
- E := GetLastError;
- if E = ERROR_INVALID_HANDLE then
- P := Pointer( G )
- else
- Exit;
- end;
- Result := DestStrm.Write( P^, Sz );
- if P <> Pointer( G ) then
- GlobalUnlock( G );
- //FreeResource( G );
- { from Win32.hlp: "You do not need to call the FreeResource
- function to free a resource loaded by using the LoadResource
- function." }
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END Resource2Stream]
-
- ///////////////////////////////////////////////////////////////////////////
- // I N I - F I L E S
- ///////////////////////////////////////////////////////////////////////////
-
- {$ifdef wince}
- {$define read_implementation}
- {$I KOLCE_IniFile.inc}
- {$undef read_implementation}
- {$else}
- { TIniFile }
-
- //[destructor TIniFile.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TIniFile.Destroy;
- begin
- fFileName := '';
- fSection := '';
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFNDEF _D5orHigher}
- // Place here correct definition for WritePrivateProfileStruct
- // and GetPrivateProfileStruct (a bug in Delphi2, Delphi3 and Delphi4)
- //[API WritePrivateProfileStruct]
- function WritePrivateProfileStruct(lpszSection, lpszKey: PChar;
- lpStruct: Pointer; uSizeStruct: UINT; szFile: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external kernel32 name 'WritePrivateProfileStructA';
- //[API GetPrivateProfileStruct]
- function GetPrivateProfileStruct(lpszSection, lpszKey: PAnsiChar;
- lpStruct: Pointer; uSizeStruct: UINT; szFile: PAnsiChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external kernel32 name 'GetPrivateProfileStructA';
-
- // + by Slava A. Gavrik:
- ////////////////////////////////////////////////////////////////////////////
- //[function WritePrivateProfileSection]
- function WritePrivateProfileSection(lpAppName, lpString,
- lpFileName: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external kernel32 name 'WritePrivateProfileSectionA';
- //[function GetPrivateProfileSection]
- function GetPrivateProfileSection(lpAppName: PChar; lpReturnedString: PChar;
- nSize: DWORD; lpFileName: PChar): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external kernel32 name 'GetPrivateProfileSectionA';
-
- //[function GetPrivateProfileSectionNames]
- function GetPrivateProfileSectionNames(lpszReturnBuffer: PChar; nSize:
- DWORD;
- lpFileName: PChar): DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external kernel32 name 'GetPrivateProfileSectionNamesA';
- ////////////////////////////////////////////////////////////////////////////
- {$ENDIF}
-
- //[procedure TIniFile.ClearAll]
- procedure TIniFile.ClearAll;
- begin
- WritePrivateProfileString( nil, nil, nil,
- PKOLChar( fFileName ) );
- end;
-
- //[procedure TIniFile.ClearKey]
- procedure TIniFile.ClearKey(const Key: KOLString);
- begin
- WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ), nil,
- PKOLChar( fFileName ) );
- end;
-
- //[procedure TIniFile.ClearSection]
- procedure TIniFile.ClearSection;
- begin
- WritePrivateProfileString( PKOLChar( fSection ), nil, nil,
- PKOLChar( fFileName ) );
- end;
-
- //[function TIniFile.ValueBoolean]
- function TIniFile.ValueBoolean(const Key: KOLString; Value: Boolean): Boolean;
- begin
- if fMode = ifmRead then
- Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
- Integer( Value ), PKOLChar( fFileName ) ) <> 0
- else
- begin
- WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
- PKOLChar( KOLString( Int2Str( Integer( Value ) ) ) ),
- PKOLChar( fFileName ) );
- Result := Value;
- end;
- end;
-
- //[function TIniFile.ValueData]
- function TIniFile.ValueData(const Key: KOLString; Value: Pointer;
- Count: Integer): Boolean;
- begin
- if fMode = ifmRead then
- Result := GetPrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
- Value, Count, PKOLChar( fFileName ) )
- else
- Result := WritePrivateProfileStruct( PKOLChar( fSection ), PKOLChar( Key ),
- Value, Count, PKOLChar( fFileName ) );
- end;
-
- //[function TIniFile.ValueInteger]
- function TIniFile.ValueInteger(const Key: KOLString; Value: Integer): Integer;
- begin
- if fMode = ifmRead then
- Result := GetPrivateProfileInt( PKOLChar( fSection ), PKOLChar( Key ),
- Integer( Value ), PKOLChar( fFileName ) )
- else
- begin
- Result := Value;
- WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
- PKOLChar( KOLString( Int2Str( Value ) ) ), PKOLChar( fFileName ) );
- end;
- end;
-
- //[function TIniFile.ValueString]
- function TIniFile.ValueString(const Key, Value: KOLString): KOLString;
- var
- Buffer: array[0..4095] of KOLChar;
- begin
- if fMode = ifmRead then
- begin
- Buffer[ 0 ] := #0;
- if GetPrivateProfileString(PKOLChar(fSection),
- PKOLChar(Key), PKOLChar(Value), Buffer, SizeOf(Buffer) div Sizeof(KOLChar),
- PKOLChar(fFileName)) <> 0 then
- Result := Buffer
- else
- Result := ''; // Ïî ïðè÷èíå òîãî, ÷òî FPC âûäàåò îøèáêó ïðè îòñóòñòâèè Key â INI-ôàéëå // MTsv DN
- end
- else
- begin
- Result := Value;
- WritePrivateProfileString( PKOLChar( fSection ), PKOLChar( Key ),
- PKOLChar( Value ), PKOLChar( fFileName ) );
- end;
- end;
-
- //[function OpenIniFile]
- function OpenIniFile( const FileName: KOLString ): PIniFile;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PIniFile.Create;*){--}
- Result.fFileName := FileName;
- end;
-
- /////////////////////////////////////////////////// GetSectionNames, SectionData
- // - by Vyacheslav A. Gavrik :
-
- const
- IniBufferSize = 32767;
- IniBufferStrSize = IniBufferSize+4; /// äëÿ ìàõèíàöèé :)
-
- //[procedure _FillStrList]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
-
- //[procedure TIniFile.GetSectionNames]
- {$IFDEF UNICODE_CTRLS}
- procedure TIniFile.GetSectionNames(Names:PWStrList);
- {$ELSE}
- procedure TIniFile.GetSectionNames(Names:PStrList);
- {$ENDIF}
- var
- i:integer;
- Pc:PKOLChar;
- PcEnd:PKOLChar;
- Buffer:Pointer;
- begin
- GetMem(Buffer,IniBufferSize * Sizeof( KOLChar ));
- Pc:=Buffer;
- i := GetPrivateProfileSectionNames(Buffer, IniBufferSize, PKOLChar(fFileName));
- PcEnd:=Pc+i;
- repeat
- Names.Add(Pc);
- Pc:=PC+Length(PC)+1;
- until PC>=PcEnd;
- FreeMem(Buffer);
- end;
-
- //[procedure TIniFile.SectionData]
- procedure TIniFile.SectionData(Names: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF});
- var
- i:integer;
- Pc:PKOLChar;
- PcEnd:PKOLChar;
- Buffer:Pointer;
- begin
- GetMem(Buffer,IniBufferSize * Sizeof(KOLChar));
- Pc:=Buffer;
- if fMode = ifmRead then
- begin
- i:=GetPrivateProfileSection(PKOLChar(fSection), Buffer, IniBufferSize, PKOLChar(fFileName));
- PcEnd:=Pc+i;
- while PC < PcEnd do // Chg by ECM from REPEAT-UNTIL: i=0 (empty section) => Names.Count=1
- begin
- Names.Add(Pc);
- Pc:=PC+Length(PC)+1;
- end;
- end else
- begin
- for i:= 0 to Names.Count-1 do
- begin
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- (Pc,Names.ItemPtrs[i]);
- Pc:=PC+Length(PC)+1;
- end;
- Pc[0]:=#0;
- ClearSection;
- WritePrivateProfileSection(PKOLChar(fSection), Buffer, PKOLChar(fFileName));
-
- end;
- FreeMem(Buffer);
- end;
- {$ENDIF ASM_VERSION}
- {$endif wince}
-
- /////////////////////////////////////////////////////////////////////////
- // M E N U
- /////////////////////////////////////////////////////////////////////////
-
- { -- Menu implementation -- }
-
- //[FUNCTION MakeAccelerator]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function MakeAccelerator( fVirt: Byte; Key: Word ): TMenuAccelerator;
- begin
- Result.fVirt := fVirt;
- Result.Key := Key;
- end;
- {$ENDIF ASM_VERSION}
- //[END MakeAccelerator]
-
- //[FUNCTION GetAcceleratorText]
- {$ifdef wince}
- function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
- begin
- Result:='';
- end;
- {$else}
- function GetAcceleratorText( const Accelerator: TMenuAccelerator ): KOLstring;
- var
- KeyName: array[0..255] of KOLChar;
-
- procedure AddKeyName( Code: Integer );
- begin
- Code := MapVirtualKey(Code, 0);
- if Code = 0 then exit;
- if GetKeyNameText(Code shl 16, KeyName, 256) > 0 then begin
- if Result <> '' then
- Result := Result + '+';
- Result := Result + KeyName;
- end;
- end;
-
- begin
- Result := '';
- with Accelerator do begin
- if fVirt and FCONTROL <> 0 then
- AddKeyName(VK_CONTROL);
- if fVirt and FSHIFT <> 0 then
- AddKeyName(VK_SHIFT);
- if fVirt and FALT <> 0 then
- AddKeyName(VK_ALT);
- if fVirt and $20 <> 0 then
- AddKeyName(VK_LWIN);
- if fVirt and $40 <> 0 then
- AddKeyName(VK_RWIN);
-
- AddKeyName(Key);
- end;
- end;
- {$endif wince}
- //[END GetAcceleratorText]
-
- const
- MIDATA_CHECKITEM = $40000000;
- MIDATA_RADIOITEM = $80000000;
-
- //[function WndProcMenu]
- {$IFNDEF NEW_MENU_ACCELL}
- function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- var M, M1: PMenu;
- Idx: Integer;
- Id: Integer;
- begin
- Result := False;
- if Msg.message = WM_COMMAND then
- begin
- if {$ifdef wince}(LOWORD( Msg.wParam ) <> 0){$else}(Msg.lParam = 0){$endif} and (HIWORD( Msg.wParam ) <= 1) then
- begin
- M := PMenu( Sender.fMenuObj );
- while (M = nil) and (Sender.Parent <> nil) do
- begin
- Sender := Sender.Parent;
- M := PMenu( Sender.fMenuObj );
- end;
- while M <> nil do
- begin
- Id := LoWord( Msg.wParam );
- M1 := M.Items[ Id ];
- if M1 <> nil then
- begin
- Result := True;
- Rslt := 0;
- Idx := M.IndexOf( M1 );
- M.fByAccel := HiWord( Msg.wParam ) <> 0;
- if M1.FRadioGroup <> 0 then
- M1.RadioCheckItem
- else
- if M1.FIsCheckItem then
- M1.Checked := not M1.Checked;
- if Assigned(M1.FOnMenuItem) then
- M1.FOnMenuItem( M, Idx )
- else if Assigned( M.FOnMenuItem ) then
- M.FOnMenuItem( M, Idx );
- break;
- end;
- M := M.fNextMenu;
- end;
- end;
- end;
- end;
-
- {$ELSE}
-
- function WndProcMenu( Sender: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
-
- function ProcessMenuItem(M: PMenu; Id: Integer): Boolean;
- var
- M1: PMenu;
- Idx: Integer;
- begin
- M1 := M.Items[ Id ];
- Result := (M1 <> nil);
- if Result then
- begin
- Idx := M.IndexOf( M1 );
- M.fByAccel := HiWord( Msg.wParam ) <> 0;
- if M1.FRadioGroup <> 0 then
- M1.RadioCheckItem
- else
- if M1.FIsCheckItem then
- M1.Checked := not M1.Checked;
- if Assigned(M1.FOnMenuItem) then begin
- {$IFDEF USE_MENU_CURCTL} // fixed
- M.fCurCtl := Sender; // fixed
- {$ENDIF} // fixed
- M1.FOnMenuItem( M, Idx )
- end
- else if Assigned( M.FOnMenuItem ) then
- M.FOnMenuItem( M, Idx );
- end;
- end;
-
- var
- M: PMenu;
- Id: Integer;
- begin
- Result := False;
- if Msg.message = WM_COMMAND then
- if {$ifdef win32}(Msg.lParam = 0) and {$endif} (HIWORD( Msg.wParam ) <= 1) then begin
- Id := LoWord(Msg.wParam);
- M := PMenu(Sender.fAutoPopupMenu);
- if (M <> nil) and ProcessMenuItem(M, Id) then begin
- Result := True;
- Rslt := 0;
- end
- else begin
- M := PMenu(Sender.fMenuObj);
- while M <> nil do begin
- if ProcessMenuItem(M, Id) then begin
- Result := True;
- Rslt := 0;
- Break;
- end;
- M := M.fNextMenu;
- end;
- end;
- end;
- end;
- {$ENDIF}
-
- {$ENDIF WIN_GDI}
-
- //[function NewMenu]
- {$IFDEF GDI}
- function NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
- const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
- var M: PMenu;
- {$IFDEF INITIALFORMSIZE_FIXMENU}
- R: TRect;
- {$ENDIF}
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PMenu.Create;*){--}
- Result.FVisible := TRUE;
- Result.FPopupFlags := TPM_LEFTALIGN or TPM_LEFTBUTTON;
- Result.FItems := NewList;
- Result.FOnMenuItem := aOnMenuItem;
- if (High(Template)>=0) and (Template[0] <> nil) then
- begin
- {$ifdef win32}
- if (AParent <> nil) and (AParent.fMenuObj = nil) and not AParent.fIsControl then
- Result.FHandle := CreateMenu
- else
- {$endif win32}
- Result.FHandle := CreatePopupMenu;
- Result.FillMenuItems( Result.FHandle, 0, Template );
- end;
- if assigned( AParent ) then
- begin
- Result.FControl := AParent;
- if AParent.fMenuObj <> nil then
- begin
- // add popup menu to the end of menu chain
- M := PMenu( AParent.fMenuObj );
- while M.fNextMenu <> nil do
- M := M.fNextMenu;
- M.fNextMenu := Result;
- end
- else
- begin
- if not AParent.fIsControl then
- begin
- {$IFDEF INITIALFORMSIZE_FIXMENU}
- R := AParent.ClientRect;
- {$ENDIF}
- {$ifdef wince}
- CeSetMenuProc:=@CeSetMenuHandler;
- AParent.fMenu:=Result.FHandle;
- if AParent.fHandle <> 0 then begin
- DestroyWindow(SHFindMenuBar(AParent.fHandle));
- CeSetMenu(AParent.fHandle, Result);
- end;
- {$else}
- AParent.Menu := Result.FHandle;
- {$endif wince}
- {$IFDEF INITIALFORMSIZE_FIXMENU}
- AParent.SetClientSize( R.Right, R.Bottom );
- {$ENDIF}
- end;
- AParent.fMenuObj := Result;
- AParent.AttachProc( WndProcMenu );
- {$IFDEF USE_AUTOFREE4CONTROLS}
- AParent.Add2AutoFree( Result );
- {$ENDIF}
- end;
- end;
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
-
- //--- some code from samples - may be useful to see "how to"
- Function AddSeparatorToMenu( Menu : PGtkMenu ) : PgtkMenuItem ;
- begin
- Result := PGtkMenuitem( gtk_menu_item_new ) ;
- gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
- gtk_widget_show( PGtkWidget ( Result ) ) ;
- end;
-
- Function AddItemToMenu( Menu : PGtkMenu;
- ShortCuts : PGtkAccelGroup;
- const Caption : AnsiString;
- const ShortCut : AnsiString;
- CallBack : TGtkSignalFunc;
- CallBackdata : Pointer ) : PGtkMenuItem;
- Var
- Key, Modifiers : DWORD;
- //LocalAccelGroup : PGtkAccelGroup; -- not used since gtk_menu_ensure_uline_accel_group not defined anywhere...
- TheLabel : PGtkLabel;
- begin
- Result := PGtkMenuItem ( gtk_menu_item_new_with_label( '' ) ) ;
- TheLabel := GTK_LABEL(GTK_BIN( Result )^.child ) ;
- Key:= gtk_label_parse_uline( TheLabel , Pchar ( Caption ) ) ;
- //----------------
- {If Key<>0 then // gtk_menu_ensure_uline_accel_group -- not defined anywhere...
- begin
- LocalAccelGroup := gtk_menu_ensure_uline_accel_group( Menu );
- gtk_widget_add_accelerator( PGtkWidget ( Result ), 'activateitem',
- LocalAccelGroup , Key ,
- 0 , TGtkAccelFlags ( 0 ) ) ;
- end;}
- //-----------------
- gtk_menu_append( GTK_WIDGET( Menu ), PGtkWidget( Result ) ) ;
- //-----------------
- If ( ShortCut<>'' ) and ( ShortCuts<> Nil ) then
- begin
- gtk_accelerator_parse ( pchar( ShortCut ) , @key , @modifiers ) ;
- gtk_widget_add_accelerator ( PGtkWidget ( Result ) , ' activateitem' ,
- ShortCuts, Key, modifiers, GTK_ACCEL_VISIBLE );
- end;
- //------------------
- If Assigned( CallBack ) then
- begin
- gtk_signal_connect( PGtkObject ( Result ) , 'activate' ,
- CallBack , CallBackdata ) ;
- gtk_widget_show( PgtkWidget ( Result ) ) ;
- end ;
- end;
-
- Function AddMenuToMenuBar( MenuBar : PGtkMenuBar;
- ShortCuts : PGtkAccelGroup;
- Caption : AnsiString;
- CallBack : TGtkSignalFunc;
- CallBackdata : Pointer;
- AlignRight : Boolean;
- Var MenuItem : PgtkMenuItem ) : PGtkMenu;
- Var Key : DWORD;
- TheLabel : PGtkLabel;
- begin
- MenuItem := PGtkMenuItem( gtk_menu_item_new_with_label( '' ) ) ;
- If AlignRight Then
- gtk_menu_item_right_justify( MenuItem );
- TheLabel := GTK_LABEL( GTK_BIN( MenuItem )^ .child ) ;
- Key := gtk_label_parse_uline( TheLabel, Pchar ( Caption ) ) ;
- If Key<>0 then
- gtk_widget_add_accelerator( PGtkWidget( MenuItem ), 'activateitem',
- Shortcuts, Key, GDK_MOD1_MASK, GTK_ACCEL_LOCKED );
- Result := PGtkMenu( gtk_menu_new );
- If Assigned( CallBack ) then
- gtk_signal_connect( PGtkObject ( Result ), 'activate',
- CallBack, CallBackdata ) ;
- gtk_widget_show( PgtkWidget ( MenuItem ) ) ;
- gtk_menu_item_set_submenu( MenuItem, PGtkWidget( Result ) ) ;
- gtk_menu_bar_append( GTK_WIDGET( MenuBar ), PgtkWidget( MenuItem ) ) ;
- end;
-
- function NewMenu( AParent : PControl; MaxCmdReserve : DWORD;
- const Template : array of PKOLChar; aOnMenuItem: TOnMenuItem ): PMenu;
- procedure CreateMenuItems( ParentMenu: PMenu; var i: Integer );
- var Item, PrevItem: PMenu;
- s: String;
- j: Integer;
- begin
- PrevItem := nil;
- while i <= High( Template )-1 do
- begin
- inc( i );
- s := Template[ i ];
- if s = '' then break; // end of template
-
- if s = ')' then
- begin
- inc( i ); break; // end of submenu
- end;
-
- new( Item, Create );
- Item.FCaption := s;
- Item.FVisible := TRUE;
- Item.FParentMenu := ParentMenu;
- if ParentMenu.FItems = nil then
- ParentMenu.FItems := NewList;
- ParentMenu.FItems.Add( Item );
-
- if (s <> '') and (s[ 1 ] in [ '+', '-' ]) then
- begin
- Item.fIsCheckItem := TRUE;
- Item.fChecked := S[ 1 ] = '+';
- s := CopyEnd( s, 2 );
- if (s <> '') and (s[ 1 ] = '!') then
- begin
- if PrevItem <> nil then
- begin
- if PrevItem.fRadioGroup <> 0 then
- Item.fRadioGroup := PrevItem.fRadioGroup;
- end
- else inc( Item.fRadioGroup );
- s := CopyEnd( s, 2 );
- end;
- end;
-
- if s = '-' then
- Item.fIsSeparator := TRUE
- else
- begin
- // extract mnemonic
- for j := Length( s )-1 downto 1 do
- begin
- if (s[ j ] = '&') and (s[ j+1 ] <> '&') then // mnemonic
- begin
- Item.fMnemonics := Item.fMnemonics + s[ j+1 ];
- Delete( s, j, 1 );//? <U>m</U> ?
- end;
- end;
- end;
-
- //---------------------------- now call gtk for create item's widget
- if Item.FIsSeparator then
- Item.fGtkMenuItem := gtk_menu_item_new
- else
- Item.fGtkMenuItem := gtk_menu_item_new_with_label( PChar( s ) );
- if ParentMenu.fGtkMenuBar <> nil then
- gtk_menu_bar_append(
- ParentMenu.fGtkMenuBar,
- Item.fGtkMenuItem )
- else
- gtk_menu_shell_append(
- GTK_MENU_SHELL( ParentMenu.fGtkMenuShell ),
- Item.fGtkMenuItem );
-
- if s = '(' then
- begin
- inc( i );
- if PrevItem <> nil then
- begin
- PrevItem.fGtkMenuShell := gtk_menu_new;
- gtk_menu_item_set_submenu(
- GTK_MENU_ITEM( PrevItem.fGtkMenuItem ),
- PrevItem.fGtkMenuShell );
- CreateMenuItems( PrevItem, i );
- end;
- end;
-
- PrevItem := Item;
- end;
- end;
- var i: Integer;
- begin
- new( Result, Create );
- i := -1;
- if AParent.fMenuObj = nil then
- begin // ñîçäàåòñÿ ãëàâíîå ìåíþ ñ ëèíåéêîé ìåíþ (íàâåðõó ôîðìû? ëþáîãî êîíòðîëà?)
- AParent.fMenuObj := Result;
- Result.fGtkMenuBar := gtk_menu_bar_new;
- //AParent.fMenuBar := Result.fGtkMenuBar;
- gtk_container_add( GTK_CONTAINER( AParent.fClient ), Result.fGtkMenuBar );
- gtk_widget_show( Result.fGtkMenuBar );
- end
- else
- begin
- PMenu( AParent.fMenuObj ).fNextMenu := Result;
- Result.fGtkMenuShell := gtk_menu_new;
- end;
- CreateMenuItems( Result, i );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- //[END NewMenu]
-
- //[function NewMenuEx]
- function NewMenuEx( AParent : PControl; FirstCmd : Integer;
- const Template : array of PKOLChar; aOnMenuItems: array of TOnMenuItem ): PMenu;
- begin
- Result := NewMenu( AParent, FirstCmd, Template, nil );
- {$IFDEF GDI}
- Result.AssignEvents( 0, aOnMenuItems );
- {$ENDIF GDI}
- end;
- //[END NewMenuEx]
-
- {$IFDEF WIN_GDI}
- { TMenu }
-
- const
- Breaks: array[ TMenuBreak ] of DWORD = ( 0, MFT_MENUBREAK, MFT_MENUBARBREAK );
-
- { + by AK - Andrzej Kubaszek }
- //[function MenuStructSize]
- function MenuStructSize: Integer;
- begin
- {$ifdef win32}
- Result := 44;
- if not( WinVer in [wv31, wv95, wvNT] ) then
- {$endif win32}
- Result := {48=} Sizeof( TMenuItemInfo );
- end;
- {$ENDIF WIN_GDI}
-
- //[destructor TMenu.Destroy]
- {$IFDEF GDI}
- destructor TMenu.Destroy;
- var Next, Prnt: PMenu;
- begin
- {$IFDEF DEBUG_MENU_DESTROY}
- LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
- Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
- {$ENDIF}
- if Count > 0 then
- begin
- FItems.ReleaseObjects;
- FItems := NewList;
- end;
- if FParentMenu <> nil then
- begin
- Prnt := FParentMenu;
- Next := Prnt.RemoveSubMenu( FId );
- Prnt.FItems.Remove( @ Self );
- {$ifdef wince}
- if FParentMenu.FParentMenu = nil then
- RedrawFormMenuBar;
- {$endif wince}
- FParentMenu := nil;
- if Next = nil then
- begin
- {$ifdef cpu86}
- asm
- nop
- end;
- {$endif cpu86}
- Exit;
- end;
- end;
- if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
- begin
- //if FControl.fHandle <> 0 then
- if not FControl.fDestroying then //!!!fix by Galkov
- begin
- {$ifdef wince}
- CeSetMenu( FControl.fHandle, 0 );
- {$else}
- Windows.SetMenu( FControl.fHandle, 0 );
- {$endif}
- // this removes main menu from window, but does not destroy it
- end;
- FControl.fMenu := 0;
- Next := PMenu( FControl.fMenuObj );
- while Next <> nil do
- begin
- if Next.fNextMenu = @Self then
- begin
- Next.fNextMenu := fNextMenu;
- break;
- end;
- Next := Next.fNextMenu;
- end;
- end;
- Next := fNextMenu;
- if FBitmap <> 0 then
- Bitmap := 0;
- if FHandle <> 0 then
- begin
- //if not
- DestroyMenu( FHandle )
- // then LogFileOutput( GetStartDir + 'err.log.txt', SysErrorMessage( GetLastError ) )
- ;
- end;
- FCaption := '';
- FItems.Free;
- Next.Free;
- inherited;
- // all later created (popup) menus (of the same control)
- // are destroyed too
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- destructor TMenu.Destroy;
- //var Next, Prnt: PMenu;
- begin
- {$IFDEF DEBUG_MENU_DESTROY}
- LogFileOutput( GetStartDir + 'TMenu.Destroy.txt',
- Int2Hex( DWORD( @ Self ), 6 ) + ' ' + Int2Str( RefCount ) );
- {$ENDIF}
- //if Count > 0 then
- if Assigned( fItems ) then
- begin
- FItems.ReleaseObjects;
- FItems := NewList;
- end;
- {if FParentMenu <> nil then
- begin
- Prnt := FParentMenu;
- Next := Prnt.RemoveSubMenu( FId );
- FParentMenu := nil;
- Prnt.FItems.Remove( @ Self );
- if Next = nil then Exit;
- end;}
- {if (FControl <> nil) and (FControl.fMenu = FHandle) and (FHandle <> 0) then
- begin
- begin
- Windows.SetMenu( FControl.fHandle, 0 );
- // this removes main menu from window, but does not destroy it
- end;
- FControl.fMenu := 0;
- Next := PMenu( FControl.fMenuObj );
- while Next <> nil do
- begin
- if Next.fNextMenu = @Self then
- begin
- Next.fNextMenu := fNextMenu;
- break;
- end;
- Next := Next.fNextMenu;
- end;
- end;}
- //Next := fNextMenu;
- //if FBitmap <> 0 then Bitmap := 0;
- //if FHandle <> 0 then DestroyMenu( FHandle );
- FCaption := '';
- fMnemonics := '';
- FItems.Free;
- //Next.Free;
- inherited;
- // all later created (popup) menus (of the same control)
- // are destroyed too
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //[function TMenu.GetInfo]
- function TMenu.GetInfo( var MII: TMenuItemInfo ): Boolean;
- begin
- MII.cbSize := MenuStructSize;
- Result := GetMenuItemInfo( Parent.FHandle, FId, FALSE,
- {Windows.}PMenuitemInfo( @ MII )^ );
- end;
-
- //[procedure TMenu.RedrawFormMenuBar]
- procedure TMenu.RedrawFormMenuBar;
- var C: PControl;
- begin
- C := TopParent.FControl;
- if not AppletTerminated then
- if (C <> nil) and not C.IsControl and (Pointer( C.fMenuObj ) = Pointer( TopParent )) and not C.fDestroying then
- {$ifdef wince}
- CeSetMenu( C.FHandle, TopParent );
- {$else}
- DrawMenuBar( C.FHandle );
- {$endif wince}
- end;
-
- //[function TMenu.SetInfo]
- function TMenu.SetInfo( var MII: TMenuItemInfo ): Boolean;
- var H: THandle;
- begin
- MII.cbSize := MenuStructSize;
- H := FHandle;
- if FParentMenu <> nil then
- H := FParentMenu.FHandle;
- if H = 0 then begin
- Result:=False;
- exit;
- end;
- {$ifdef wince}
- if (FHandle <> 0) and (FParentMenu <> nil) then begin
- FParentMenu.SaveState;
- DestroyMenu(FHandle);
- FParentMenu.ReCreate;
- Result:=True;
- end
- else
- if MII.fMask and MIIM_STATE <> 0 then begin
- EnableMenuItem(H, FId, MII.fState and MFS_DISABLED);
- CheckMenuItem(H, FId, MII.fState and MFS_CHECKED);
- Result:=True;
- end
- else
- {$endif wince}
- // {$IFNDEF UNICODE_CTRLS}
- Result := SetMenuItemInfo( H, FId, FALSE, {Windows.}PMenuitemInfo( @ MII )^ );
- // {$ELSE}
- // Result := SetMenuItemInfoW( H, FId, FALSE, Windows.PMenuitemInfoW( @ MII )^ );
- // {$ENDIF}
- if Result and ((FParentMenu = nil) or (FParentMenu.FParentMenu = nil)) then
- RedrawFormMenuBar;
- end;
-
- //[function TMenu.SetTypeInfo]
- function TMenu.SetTypeInfo( var MII: TMenuItemInfo ): Boolean;
- begin
- if not FIsSeparator then
- begin
- if FBmpItem = 0 then
- MII.dwTypeData := PKOLChar( FCaption )
- else
- MII.dwTypeData := Pointer( FBmpItem );
- MII.cch := Length( FCaption )*SizeOfKOLChar;
- end;
- Result := SetInfo( MII );
- end;
-
- //[function TMenu.GetTopParent]
- function TMenu.GetTopParent: PMenu;
- begin
- Result := @ Self;
- while Result.FParentMenu <> nil do
- Result := Result.FParentMenu;
- end;
-
- //[function TMenu.GetControl]
- function TMenu.GetControl: PControl;
- begin
- Result := TopParent.FControl;
- end;
-
- //[function TMenu.GetItems]
- function TMenu.GetItems( Id: HMenu ): PMenu;
- function SearchItems( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
- var I: Integer;
- begin
- Result := ParentMenu;
- if Id = HMenu( FromIdx ) then Exit;
- if (Id >= 4096) and (DWORD( ParentMenu.FId ) = Id) then Exit;
- if ParentMenu.FItems = nil then Exit;
- for I := 0 to ParentMenu.FItems.FCount-1 do
- begin
- Inc( FromIdx );
- Result := SearchItems( ParentMenu.FItems.Items[ I ], FromIdx );
- if Result <> nil then Exit;
- end;
- Result := nil;
- end;
- var I: Integer;
- begin
- I := -1;
- Result := SearchItems( @ Self, I );
- end;
-
- //[function TMenu.GetCount]
- function TMenu.GetCount: Integer;
- var I: Integer;
- SubM: PMenu;
- begin
- Result := FItems.FCount;
- for I := 0 to Result-1 do
- begin
- SubM := FItems.Items[ I ];
- Result := Result + SubM.Count;
- end;
- end;
-
- //[function TMenu.IndexOf]
- function TMenu.IndexOf( Item: PMenu ): Integer;
- function SearchMenu( ParentMenu: PMenu; var FromIdx: Integer ): PMenu;
- var I: Integer;
- begin
- Result := ParentMenu;
- if Result = Item then Exit;
- for I := 0 to ParentMenu.FItems.FCount-1 do
- begin
- Inc( FromIdx );
- Result := SearchMenu( ParentMenu.FItems.Items[ I ], FromIdx );
- if Result <> nil then Exit;
- end;
- Result := nil;
- end;
- begin
- Result := -1;
- if SearchMenu( @ Self, Result ) = nil then
- Result := -2;
- end;
-
- //[function TMenu.GetState]
- function TMenu.GetState( const Index: Integer ): Boolean;
- var MII: TMenuItemInfo;
- begin
- if FVisible then
- begin
- MII.fMask := MIIM_STATE;
- if GetInfo( MII ) then
- FSavedState := MII.fState;
- end;
- Result := LongBool( FSavedState and Index );
- if Index < 0 then
- Result := not Result;
- end;
-
- //[procedure TMenu.SetState]
- procedure TMenu.SetState( const Index: Integer; Value: Boolean );
- var MII: TMenuItemInfo;
- begin
- GetState( 0 );
- if Value xor (Index < 0) then
- FSavedState := FSavedState or DWORD( Index and $7FFFFFFF )
- else
- FSavedState := FSavedState and not DWORD( Index );
- if FVisible then
- begin
- MII.fMask := MIIM_STATE;
- if GetInfo( MII ) then
- begin
- MII.fState := FSavedState;
- SetInfo( MII );
- end;
- end;
- end;
-
- //[procedure TMenu.SetData]
- procedure TMenu.SetData( Value: Pointer );
- var MII: TMenuItemInfo;
- begin
- MII.fMask := MIIM_DATA;
- MII.dwItemData := DWORD( Value );
- SetInfo( MII );
- FData := Value;
- end;
-
- //[procedure TMenu.ClearBitmaps]
- procedure TMenu.ClearBitmaps;
- begin
- if FBitmap <> 0 then
- DeleteObject( FBitmap );
- if FBmpChecked <> 0 then
- DeleteObject( FBmpChecked );
- if FBmpItem <> 0 then
- DeleteObject( FBmpItem );
- end;
-
- //[procedure TMenu.SetBitmap]
- procedure TMenu.SetBitmap( Value: HBitmap );
- var MII: TMenuItemInfo;
- begin
- if not FClearBitmaps then
- begin
- FClearBitmaps := TRUE;
- Add2AutoFreeEx( ClearBitmaps );
- end;
- if Value = FBitmap then Exit;
- if FBitmap <> 0 then
- DeleteObject( FBitmap ); // seems not necessary.
- FBitmap := Value;
- MII.fMask := MIIM_CHECKMARKS;
- MII.hbmpChecked := FBmpChecked;
- MII.hbmpUnchecked := FBitmap;
- SetInfo( MII );
- end;
-
- //[procedure TMenu.SetBmpChecked]
- procedure TMenu.SetBmpChecked( Value: HBitmap );
- var MII: TMenuItemInfo;
- begin
- if not FClearBitmaps then
- begin
- FClearBitmaps := TRUE;
- Add2AutoFreeEx( ClearBitmaps );
- end;
- if Value = FBmpChecked then Exit;
- if FBmpChecked <> 0 then
- DeleteObject( FBmpChecked );
- FBmpChecked := Value;
- MII.fMask := MIIM_CHECKMARKS;
- MII.hbmpChecked := FBmpChecked;
- MII.hbmpUnchecked := FBitmap;
- SetInfo( MII );
- end;
-
- //[procedure TMenu.SetBmpItem]
- procedure TMenu.SetBmpItem( Value: HBitmap );
- var MII: TMenuItemInfo;
- begin
- if not FClearBitmaps then
- begin
- FClearBitmaps := TRUE;
- Add2AutoFreeEx( ClearBitmaps );
- end;
- if Value = FBmpItem then Exit;
- if FBmpItem <> 0 then
- DeleteObject( FBmpItem );
- FBmpItem := Value;
- {$ifdef win32}
- if WinVer >= wv98 then {AK}
- begin {AK}
- MII.fMask := $80 {MIIM_BITMAP} ; {AK}
- MII.hbmpItem:=Value; {AK}
- end {AK}
- else {AK}
- {$endif}
- begin//I haven't possibility to test it in Win95 {AK}
- MII.fType := MFT_BITMAP;
- MII.dwItemData := Value;
- end; {AK}
- SetInfo( MII );
- end;
-
- //[procedure TMenu.SetAccelerator]
- {$IFNDEF NEW_MENU_ACCELL}
- procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
- const MaxAccel = 1000;
- type TAccTab = array[0..10000] of TAccel;
- PAccTab = ^TAccTab;
- var AccTab: PAccTab;
- I, N : Integer;
- M, SubM: PMenu;
- C: PControl;
- Main: Boolean;
- begin
- if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;
- FAccelerator := Value;
- C := TopParent.FControl;
- if C = nil then Exit;
- if C.fAccelTable <> 0 then
- DestroyAcceleratorTable( C.fAccelTable );
- C.fAccelTable := 0;
- GetMem( AccTab, sizeof( TAccel ) * MaxAccel );
- N := 0;
- M := PMenu( C.fMenuObj );
- Main := TRUE;
- while M <> nil do
- begin
- if Main or M.Visible then
- begin
- for I := 0 to MaxInt-1 do
- begin
- SubM := M.Items[ I ];
- if SubM = nil then break;
- if SubM.FVisible then
- if (SubM.FAccelerator.Key <> 0) or (SubM.FAccelerator.fVirt <> 0) then
- begin
- AccTab[ N ].fVirt := SubM.FAccelerator.fVirt;
- AccTab[ N ].key := SubM.FAccelerator.Key;
- AccTab[ N ].cmd := WORD( SubM.FId );
- Inc( N );
- if N > MaxAccel then break;
- end;
- end;
- end;
- if N > MaxAccel then break;
- M := M.fNextMenu;
- end;
- if N > 0 then
- begin
- C.fAccelTable := CreateAcceleratorTable( AccTab[ 0 ], N );
- {$IFDEF USE_AUTOFREE4CONTROLS}
- C.Add2AutoFreeEx( C.DoDestroyAccelTable );
- {$ENDIF}
- C := C.ParentForm;
- if C <> nil then
- C.SupportMnemonics;
- end;
- FreeMem( AccTab );
- end;
-
- {$ELSE NEW_MENU_ACCELL}
-
- procedure TMenu.SetAccelerator(const Value: TMenuAccelerator);
- var
- C: PControl;
- M: PMenu;
- begin
- if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then Exit;
- FAccelerator := Value;
- C := FControl;
- M := @Self;
- while (C = nil) and (M <> nil) do begin
- M := M.Parent;
- if (M <> nil) then
- C := M.FControl;
- end;
- if (C <> nil) then
- C.SupportMnemonics;
- end;
-
- {$ENDIF NEW_MENU_ACCELL}
-
- //[procedure TMenu.SetMenuItemCaption]
- procedure TMenu.SetMenuItemCaption( const Value: KOLString );
- var MII: TMenuItemInfo;
- begin
- FCaption := Value;
- if FParentMenu = nil then Exit; {+ecm}
- {$ifdef win32}
- {AK}if not (WinVer in [wv95,wvNT]) then
- {AK} MII.fMask := $40 {MIIM_STRING}
- {AK}else begin
- {$endif win32}
- MII.fMask := MIIM_TYPE;
- MII.fType := MFT_STRING;
- {$ifdef win32}
- {AK}end;
- {$endif win32}
- MII.dwTypeData:=nil;
- MII.cch := 0; // to fix turning radio mark to check mark in NT4
- GetInfo( MII ); //-----------------------------------------------
- MII.dwTypeData := PKOLChar( Value );
- MII.cch := Length( Value )*SizeOfKOLChar;
- SetInfo( MII );
- end;
-
- //[procedure TMenu.SetMenuBreak]
- procedure TMenu.SetMenuBreak( Value: TMenuBreak );
- var MII: TMenuItemInfo;
- begin
- if FId = 0 then Exit;
- if FMenuBreak = Value then Exit;
- FMenuBreak := Value;
- FillChar( MII, Sizeof( MII ), #0 );
- MII.fMask := MIIM_TYPE;
- MII.dwTypeData := nil;
- if GetInfo( MII ) then
- begin
- MII.fType := MII.fType and not( MFT_MENUBREAK or MFT_MENUBARBREAK ) or
- Breaks[ Value ];
- SetTypeInfo( MII );
- end;
- end;
-
- //[procedure TMenu.SetVisible]
- procedure TMenu.SetVisible( Value: Boolean );
- var I, MPos: Integer;
- M: PMenu;
- MII: TMenuItemInfo;
- begin
- if Value then
- if FParentMenu <> nil then
- FParentMenu.Visible := TRUE;
- if Value = FVisible then Exit;
- FVisible := Value;
- if (FControl <> nil) and (FControl.fMenuObj = @ Self) then
- begin
- FControl.GetWindowHandle;
- {$ifdef wince}
- if Value then
- CeSetMenu( FControl.fHandle, TopParent )
- else
- CeSetMenu( FControl.fHandle, nil );
- {$else}
- if Value then
- SetMenu( FControl.fHandle, FHandle )
- else
- SetMenu( FControl.fHandle, 0 );
- {$endif wince}
- Exit;
- end;
- if FId = 0 then Exit;
- if FParentMenu = nil then Exit;
- MPos := 0;
- for I := 0 to FParentMenu.FItems.FCount-1 do
- begin
- M := FParentMenu.FItems.Items[ I ];
- if M = @Self then
- break;
- if M.FVisible then
- Inc(MPos);
- end;
- if Value then
- begin // show menu item inserting it again into appropriate position
- FillChar( MII, Sizeof( MII ), #0 );
- MII.cbSize := MenuStructSize;
- MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or
- MIIM_TYPE;
- MII.fType := Breaks[ FMenuBreak ];
- MII.fState := FSavedState;
- MII.wID := FId;
- MII.dwItemData := DWORD( FData );
-
- if not FIsSeparator then
- begin
- MII.fType := MII.fType or MFT_STRING;
- MII.dwTypeData := PKOLChar( FCaption );
- MII.cch := Length( FCaption );
- end
- else
- MII.fType := MII.fType or MFT_SEPARATOR;
-
- if FRadioGroup <> 0 then
- MII.fType := MII.fType or MFT_RADIOCHECK;
-
- if FOwnerDraw then
- MII.fType := MII.fType or MFT_OWNERDRAW;
-
- if FBitmap <> 0 then
- begin
- MII.fMask := MII.fMask or MIIM_CHECKMARKS;
- MII.hbmpUnchecked := FBitmap;
- end;
-
- if FHandle <> 0 then
- begin
- MII.fMask := MII.fMask or MIIM_SUBMENU;
- MII.hSubMenu := FHandle;
- end;
- InsertMenuItem( FParentMenu.FHandle, MPos, True, PMenuitemInfo( @ MII )^ );
- end
- else
- begin // hide menu item removing it
- GetState( 0 ); // store menu item state in FSavedState to allow
- // changing its state while it is not attached to
- // a menu
- RemoveMenu( FParentMenu.FHandle, MPos, MF_BYPOSITION );
- end;
- if (FControl <> nil) or (FParentMenu <> nil) and (FParentMenu.FControl <> nil) then
- RedrawFormMenuBar;
- end;
-
- //[procedure TMenu.RadioCheckItem]
- procedure TMenu.RadioCheckItem;
- var I, J: Integer;
- M, First, Last: PMenu;
- begin
- if (FParentMenu <> nil) and (FRadioGroup <> 0) then
- begin
- I := FParentMenu.FItems.IndexOf( @ Self );
- if I >= 0 then
- begin
- First := @ Self;
- Last := @ Self;
- for J := I-1 downto 0 do
- begin
- M := FParentMenu.FItems.Items[ J ];
- if M.FRadioGroup <> FRadioGroup then break;
- if M.FVisible then
- First := M;
- end;
- for J := I+1 to FParentMenu.FItems.FCount-1 do
- begin
- M := FParentMenu.FItems.Items[ J ];
- if M.FRadioGroup <> FRadioGroup then break;
- if M.FVisible then
- Last := M;
- end;
- if First <> Last then
- begin
- CheckMenuRadioItem( FParentMenu.FHandle, First.FId, Last.FId,
- FId, MF_BYCOMMAND {or MF_CHECKED} );
- Exit;
- end;
- end;
- end;
- Checked := TRUE;
- end;
-
- //[function TMenu.FillMenuItems]
- function TMenu.FillMenuItems(AHandle: HMenu; StartIdx: Integer;
- const Template: array of PKOLChar): Integer;
- var S, S1: PKOLChar;
- I: Integer;
- MII: TMenuItemInfo;
- Item, PrevItem: PMenu;
- begin
- PrevItem := nil;
- I := StartIdx;
- while I <= High( Template ) do
- begin
- S := Template[ I ];
- if (S = nil) or (S^ = #0) then break;
- if String( S ) = {$IFDEF F_P}'' +{$ENDIF} ')' then
- begin
- Inc(I);
- break;
- end;
-
- {-}
- new( Item, Create );
- {+}{++}(*Item := PMenu.Create;*){--}
- Item.FVisible := TRUE;
- Item.FParentMenu := @ Self;
- Item.FItems := NewList;
- FItems.Add( Item );
-
- FillChar( MII, Sizeof( MII ), #0 );
- MII.cbSize := MenuStructSize;
- MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
- if String( S ) <> {$IFDEF F_P}'' +{$ENDIF} '-' then
- begin
- if (S^ = {$IFDEF F_P}'' +{$ENDIF} '-') or
- (S^ = {$IFDEF F_P}'' +{$ENDIF} '+') then
- begin
- Item.FIsCheckItem := TRUE;
- {$ifdef win32}
- MII.dwItemData := MIDATA_CHECKITEM;
- {$endif win32}
- if S^ <> {$IFDEF F_P}'' +{$ENDIF} '-' then
- MII.fState := MII.fState or MFS_CHECKED;
- Inc( S );
- if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
- begin
- MII.fType := MII.fType or MFT_RADIOCHECK;
- {$ifdef win32}
- MII.dwItemData := MII.dwItemData or MIDATA_RADIOITEM;
- {$endif win32}
- Inc( S );
- if PrevItem <> nil then
- begin
- if PrevItem.FRadioGroup <> 0 then
- Item.FRadioGroup := PrevItem.FRadioGroup;
- end;
- if Item.FRadioGroup = 0 then
- Inc( Item.FRadioGroup );
- if S^ = {$IFDEF F_P}'' +{$ENDIF} '!' then
- begin
- Inc( S );
- Inc( Item.FRadioGroup );
- end;
- end;
- end;
- Item.FCaption := S;
- end
- else
- begin
- Item.FIsSeparator := TRUE;
- MII.fType := MFT_SEPARATOR;
- MII.fState := MFS_GRAYED;
- MII.wID := 0;
- end;
- Item.FId := FDynamicMenuID;
- Inc( FDynamicMenuID );
- MII.wID := Item.FId;
- if I <> High( Template ) then
- begin
- S1 := Template[ I + 1 ];
- if String( S1 ) = {$IFDEF F_P}'' +{$ENDIF} '(' then Item.FHandle := CreatePopupMenu;
- end;
- MII.hSubMenu := Item.FHandle;
- MII.dwTypeData := PKOLChar( S );
- MII.cch := {$IFDEF UNICODE_CTRLS} WStrLen( S ) {$ELSE} StrLen( S ) {$ENDIF};
- InsertMenuItem( AHandle, DWORD(-1), True, PMenuitemInfo( @ MII )^ );
- if Item.FHandle <> 0 then
- I := Item.FillMenuItems( Item.FHandle, I + 2, Template )
- else
- Inc( I );
- PrevItem := Item;
- end;
- Result := I;
- end;
-
- //[procedure TMenu.AssignEvents]
- procedure TMenu.AssignEvents(StartIdx: Integer;
- const Events: array of TOnMenuItem);
- var I: Integer;
- M: PMenu;
- begin
- for I := 0 to High(Events) do
- begin
- M := Items[ StartIdx ];
- if M = nil then break;
- M.FOnMenuItem := Events[ I ];
- Inc( StartIdx );
- end;
- end;
-
- //[procedure TMenu.Popup]
- function TMenu.Popup(X, Y: Integer): Integer;
- {$ifdef wince}
- var
- OldFlags: DWORD;
- {$endif wince}
- begin
- {$IFDEF GDI}
- if Assigned( fOnPopup ) then fOnPopup( @Self );
- if not FNotPopup then begin
- {$ifdef wince}
- OldFlags:=Flags;
- Flags:=Flags or $1000;
- {$endif wince}
- Result := Integer( TrackPopupMenu( FHandle, {$ifdef wince} OldFlags {$else} FPopupFlags {$endif},
- X, Y, 0, FControl.Handle, nil ) );
- {$ifdef wince}
- Flags:=OldFlags;
- {$endif wince}
- end
- else Result := 0;
- {$ENDIF GDI}
- end;
-
- //[procedure TMenu.PopupEx]
- function TMenu.PopupEx( X, Y: Integer ): Integer;
- {$IFDEF GDI}
- var OldBounds: TRect;
- WasVisible: Boolean;
- {$ENDIF GDI}
- begin
- {$IFDEF GDI}
- WasVisible := TRUE;
- if FControl <> nil then
- begin
- OldBounds := FControl.BoundsRect;
- if not FControl.fIsControl then
- begin
- WasVisible := FControl.Visible;
- if not WasVisible then
- FControl.Top := ScreenHeight + 50;
- FControl.Show;
- end;
- end;
-
- // -- by Martin Larsen: -----------------------
- FControl.ProcessMessage; // specific for Win9x
-
- Result := Popup( X, Y ); {*ecm}
- if FControl <> nil then
- begin
- if FControl.Top = ScreenHeight + 50 then
- begin
- if not WasVisible then
- FControl.Visible := FALSE;
- FControl.BoundsRect := OldBounds;
- end;
- end;
- {$ENDIF GDI}
- end;
-
- //[function TMenu.GetItemChecked]
- function TMenu.GetItemChecked( Item : Integer ) : Boolean;
- begin
- Result := Items[ Item ].Checked;
- end;
-
- //[procedure TMenu.SetItemChecked]
- procedure TMenu.SetItemChecked( Item : Integer; Value : Boolean );
- begin
- Items[ Item ].Checked := Value;
- end;
-
- //[function TMenu.GetMenuItemHandle]
- function TMenu.GetMenuItemHandle( Idx : Integer ): DWORD;
- begin
- Result := Items[ Idx ].FId;
- end;
-
- //[procedure TMenu.RadioCheck]
- procedure TMenu.RadioCheck( Idx : Integer );
- begin
- Items[ Idx ].RadioCheckItem;
- end;
-
- //[function TMenu.GetItemBitmap]
- function TMenu.GetItemBitmap(Idx: Integer): HBitmap;
- begin
- Result := Items[ Idx ].Bitmap;
- end;
-
- //[procedure TMenu.SetItemBitmap]
- procedure TMenu.SetItemBitmap(Idx: Integer; const Value: HBitmap);
- begin
- Items[ Idx ].Bitmap := Value;
- end;
-
- //[procedure TMenu.AssignBitmaps]
- procedure TMenu.AssignBitmaps(StartIdx: Integer; Bitmaps: array of HBitmap);
- var I: Integer;
- begin
- for I := 0 to High(Bitmaps) do
- ItemBitmap[ I + StartIdx ] := Bitmaps[ I ];
- end;
-
- //[function TMenu.GetItemText]
- function TMenu.GetItemText(Idx: Integer): KOLString;
- begin
- Result := Items[ Idx ].FCaption;
- end;
-
- //[procedure TMenu.SetItemText]
- procedure TMenu.SetItemText(Idx: Integer; const Value: KOLString);
- begin
- Items[ Idx ].Caption := Value;
- end;
-
- //[function TMenu.GetItemEnabled]
- function TMenu.GetItemEnabled(Idx: Integer): Boolean;
- begin
- Result := Items[ Idx ].Enabled;
- end;
-
- //[procedure TMenu.SetItemEnabled]
- procedure TMenu.SetItemEnabled(Idx: Integer; const Value: Boolean);
- begin
- Items[ Idx ].Enabled := Value;
- end;
-
- //[function TMenu.GetItemVisible]
- function TMenu.GetItemVisible(Idx: Integer): Boolean;
- begin
- Result := Items[ Idx ].Visible;
- end;
-
- //[procedure TMenu.SetItemVisible]
- procedure TMenu.SetItemVisible(Idx: Integer; const Value: Boolean);
- begin
- Items[ Idx ].Visible := Value;
- end;
-
- //[function TMenu.ParentItem]
- function TMenu.ParentItem( Idx: Integer ): Integer;
- begin
- Result := TopParent.IndexOf( Items[ Idx ].FParentMenu );
- end;
-
- //[function TMenu.GetItemAccelerator]
- function TMenu.GetItemAccelerator(Idx: Integer): TMenuAccelerator;
- begin
- Result := Items[ Idx ].Accelerator;
- end;
-
- //[procedure TMenu.SetItemAccelerator]
- procedure TMenu.SetItemAccelerator(Idx: Integer; const Value: TMenuAccelerator);
- begin
- Items[ Idx ].Accelerator := Value;
- end;
-
- //[function TMenu.GetItemSubMenu]
- function TMenu.GetItemSubMenu( Idx: Integer ): HMenu;
- begin
- Result := Items[ Idx ].SubMenu;
- end;
- {$ifdef wince}
- procedure TMenu.ReCreate;
- var
- MII: TMenuItemInfo;
- i, j: integer;
- begin
- if FHandle = 0 then exit;
- while RemoveMenu(FHandle, 0, MF_BYPOSITION) do ;
- j:=0;
- for i:=0 to FItems.Count - 1 do
- with PMenu(FItems.Items[i])^ do begin
- if FHandle <> 0 then
- DestroyMenu(FHandle);
- if FItems.Count > 0 then
- FHandle:=CreatePopupMenu
- else
- FHandle:=0;
- if Visible then begin
- FillChar( MII, Sizeof( MII ), 0 );
- MII.cbSize := SizeOf(MII);
- MII.fMask := MIIM_CHECKMARKS or MIIM_ID or MIIM_STATE or MIIM_TYPE;
- MII.fType := Breaks[ FMenuBreak ];
- MII.fState := FSavedState;
- MII.wID := FId;
- MII.dwItemData := DWORD( FData );
- if not FIsSeparator then
- begin
- MII.fType := MII.fType or MFT_STRING;
- MII.dwTypeData := PKOLChar( FCaption );
- MII.cch := Length( FCaption );
- end
- else
- MII.fType := MII.fType or MFT_SEPARATOR;
- if FRadioGroup <> 0 then
- MII.fType := MII.fType or MFT_RADIOCHECK;
- if FOwnerDraw then
- MII.fType := MII.fType or MFT_OWNERDRAW;
- if FBitmap <> 0 then
- begin
- MII.fMask := MII.fMask or MIIM_CHECKMARKS;
- MII.hbmpUnchecked := FBitmap;
- end;
- if FHandle <> 0 then
- begin
- MII.fMask := MII.fMask or MIIM_SUBMENU;
- MII.hSubMenu := FHandle;
- end;
- InsertMenuItem( Self.FHandle, j, True, PMenuitemInfo( @ MII )^ );
- Inc(j);
- end;
- if FHandle <> 0 then
- ReCreate;
- end;
- end;
-
- procedure TMenu.SaveState;
- var
- i: integer;
- begin
- for i:=0 to FItems.Count - 1 do
- with PMenu(FItems.Items[i])^ do begin
- GetState(0);
- if SubMenu <> 0 then
- SaveState;
- end;
- end;
- {$endif wince}
- //[function WndProcHelp FORWARD DECLARATION]
- function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- forward;
-
- {$IFDEF GDI}
- //[procedure TMenu.SetHelpContext]
- procedure TMenu.SetHelpContext( Value: Integer );
- {$ifdef wince}
- begin
- {$else}
- var Form, C: PControl;
- begin
- if TopParent <> @ Self then Exit;
- // Help context can not be associated with individual menu items
- FHelpContext := Value;
- C := FControl;
- if C = nil then Exit;
- Form := C.ParentForm;
- Form.AttachProc( WndProcHelp );
- SetMenuContextHelpID( FHandle, Value );
- {$endif wince}
- end;
- {$ENDIF GDI}
-
- //[procedure TMenu.SetSubmenu]
- procedure TMenu.SetSubmenu( Value: HMenu );
- var MII: TMenuItemInfo;
- begin
- MII.fMask := MIIM_SUBMENU;
- MII.hSubMenu := Value;
- SetInfo( MII );
- FHandle := Value;
- end;
-
- //[function WndProcMeasureItem]
- function WndProcMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var MIS: PMeasureItemStruct;
- M, SM: PMenu;
- H, I: Integer;
- begin
- Result := FALSE;
- if (Msg.message = WM_MEASUREITEM) and (Msg.wParam = 0) then
- begin
- MIS := Pointer( Msg.lParam );
- if MIS.CtlType = ODT_MENU then
- begin
- M := Pointer( Sender.fMenuObj );
- while M <> nil do
- begin
- SM := M.Items[ MIS.itemID ];
- if SM <> nil then
- begin
- Sender.CallDefWndProc( Msg );
- I := M.IndexOf( SM );
- if Assigned( SM.OnMeasureItem ) then
- M := SM;
- if not Assigned( M.OnMeasureItem ) then
- Exit;
- H := M.OnMeasureItem( M, I );
- if HiWord( H ) <> 0 then
- MIS.itemWidth := HiWord( H );
- if LoWord( H ) <> 0 then
- MIS.itemHeight := LoWord( H );
- Rslt := 1;
- Result := TRUE;
- break;
- end;
- M := M.fNextMenu;
- end;
- end;
- end;
- end;
-
- //[procedure TMenu.SetOnMeasureItem]
- procedure TMenu.SetOnMeasureItem( const Value: TOnMeasureItem );
- var C: PControl;
- begin
- FOnMeasureItem := Value;
- C := TopParent.FControl;
- if C <> nil then
- C.AttachProc( WndProcMeasureItem );
- end;
-
- //[function WndProcDrawItem]
- function WndProcDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- type PDrawAction = ^TDrawAction;
- PDrawState = ^TDrawState;
- var DIS: PDrawItemStruct;
- M, SM: PMenu;
- I: Integer;
- begin
- Result := FALSE;
- if (Msg.message = WM_DRAWITEM) and (Msg.wParam = 0) then
- begin
- DIS := Pointer( Msg.lParam );
- if DIS.CtlType = ODT_MENU then
- begin
- M := Pointer( Sender.fMenuObj );
- while M <> nil do
- begin
- SM := M.Items[ DIS.itemID ];
- if SM <> nil then
- begin
- I := M.IndexOf( SM );
- if Assigned( SM.OnDrawItem ) then
- M := SM;
- if Assigned( M.OnDrawItem ) then
- begin
- if not M.OnDrawItem( M, DIS.hDC, DIS.rcItem, I,
- PDrawAction( @ DIS.itemAction )^,
- PDrawState( @ DIS.itemState )^ ) then Exit;
- end
- else Exit;
- Rslt := 1;
- Result := TRUE;
- break;
- end;
- M := M.fNextMenu;
- end;
- end;
- end;
- end;
-
- //[procedure TMenu.SetOnDrawItem]
- procedure TMenu.SetOnDrawItem( const Value: TOnDrawItem );
- var C: PControl;
- begin
- FOnDrawItem := Value;
- C := TopParent.FControl;
- if C <> nil then
- C.AttachProc( WndProcDrawItem );
- end;
-
- //[procedure TMenu.SetOwnerDraw]
- procedure TMenu.SetOwnerDraw( Value: Boolean );
- const Masks: array[ Boolean ] of DWORD = ( 0, $FFFFFFFF );
- var MII: TMenuItemInfo;
- begin
- FOwnerDraw := Value;
- FillChar( MII, Sizeof( MII ), #0 );
- MII.fMask := MIIM_TYPE;
- MII.dwTypeData := nil;
- if GetInfo( MII ) then
- begin
- MII.fType := MII.fType and not MFT_OWNERDRAW or
- (MFT_OWNERDRAW and Masks[ Value ]);
- SetTypeInfo( MII );
- end;
- end;
-
- //[function TMenu.Insert]
- function TMenu.Insert(InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
- Options: TMenuOptions): PMenu;
- const
- MenuStateFlags: array[TMenuOption] of Integer = (MFS_DEFAULT, MFS_DISABLED, MFS_CHECKED, 0, 0,
- MFS_DISABLED, 0, 0, 0, 0);
- MenuTypeFlags: array[TMenuOption] of Integer = (0, 0, 0, 0, MFT_RADIOCHECK, MFT_SEPARATOR, MFT_BITMAP, 0,
- MFT_MENUBREAK, MFT_MENUBARBREAK);
- var M: PMenu;
- MII: TMenuItemInfo;
- begin
- {-}
- new( Result, Create );
- {+}{++}(*Result := PMenu.Create;*){--}
- Result.FVisible := TRUE;
- Result.FParentMenu := @ Self;
- Result.FItems := NewList;
- Result.FIsSeparator := moSeparator in Options;
- if FHandle = 0 then
- SetSubMenu( CreatePopupMenu );
- M := nil;
- if (InsertBefore >= 0) and (InsertBefore < 4096) then
- begin
- M := Items[ InsertBefore ];
- if M <> nil then
- begin
- InsertBefore := M.FId;
- M.Parent.FItems.Insert( M.Parent.FItems.IndexOf( M ), Result );
- end;
- end;
- if M = nil then
- begin
- InsertBefore := -1;
- FItems.Add( Result );
- end;
- Result.FOnMenuItem := Event;
-
- FillChar( MII, Sizeof( MII ), #0 );
- MII.cbSize := MenuStructSize;
- MII.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
-
- MII.fState := MakeFlags( Pointer( @Options ), MenuStateFlags);
- {$ifdef wince}
- Result.FSavedState:=MII.fState;
- {$endif wince}
- MII.fType := MakeFlags( Pointer( @Options ), MenuTypeFlags);
- Result.FId := FDynamicMenuID;
- Inc( FDynamicMenuID );
- MII.wID := Result.FId;
- if moSubMenu in Options
- then begin
- Result.FHandle := CreatePopupMenu;
- MII.hSubMenu := Result.FHandle;
- end;
- MII.dwTypeData := PKOLChar(ACaption);
- {$IFNDEF UNICODE_CTRLS}
- if not (moBitmap in Options) then MII.cch := StrLen( ACaption );
- {$ELSE}
- if not (moBitmap in Options) then MII.cch := WStrLen( ACaption );
- {$ENDIF}
- InsertMenuItem( FHandle, InsertBefore, InsertBefore = -1,
- PMenuItemInfo( @ MII )^ );
- if moBitmap in Options then
- begin
- Result.BitmapItem := DWORD( ACaption );
- end
- else
- Result.FCaption := ACaption;
- RedrawFormMenuBar;
- end;
-
- //[function TMenu.AddItem]
- function TMenu.AddItem(ACaption: PKOLChar; Event: TOnMenuItem; Options: TMenuOptions): Integer;
- begin
- Result := InsertItem( -1, ACaption, Event, Options );
- end;
-
- //[function TMenu.InsertItem]
- function TMenu.InsertItem( InsertBefore: Integer; ACaption: PKOLChar; Event: TOnMenuItem;
- Options: TMenuOptions): Integer;
- begin
- Result := InsertItemEx( InsertBefore, ACaption, Event, Options, FALSE );
- end;
-
- //[function TMenu.InsertItemEx]
- function TMenu.InsertItemEx(InsertBefore: Integer; ACaption: PKOLChar;
- Event: TOnMenuItem; Options: TMenuOptions; ByPosition: Boolean): Integer;
- var M: PMenu;
- begin
- M := Insert( InsertBefore, ACaption, Event, Options );
- Result := M.FId;
- end;
-
- //[procedure TMenu.InsertSubMenu]
- procedure TMenu.InsertSubMenu( SubMenuToInsert: PMenu; InsertBefore: Integer );
- var AFlags: DWORD;
- M: PMenu;
- {$ifndef wince}
- MII: TMenuItemInfo;
- {$endif wince}
- begin
- if SubMenuToInsert.FParentMenu <> nil then
- SubMenuToInsert := SubMenuToInsert.FParentMenu.RemoveSubMenu( SubMenuToInsert.FId );
- if SubMenuToInsert = nil then Exit;
-
- AFlags := MF_BYPOSITION;
- M := nil;
- if (InsertBefore >= 0) and (InsertBefore < 4096) then
- begin
- M := Items[ InsertBefore ];
- if M = nil then
- InsertBefore := -1
- else
- InsertBefore := M.FId;
- end;
- if M = nil then
- begin
- FItems.Add( SubMenuToInsert );
- SubMenuToInsert.FParentMenu := @ Self;
- end
- else
- begin
- M.FParentMenu.FItems.Insert( M.FParentMenu.FItems.IndexOf( M ), SubMenuToInsert );
- SubMenuToInsert.FParentMenu := M.FParentMenu;
- end;
-
- if InsertBefore > 0 then
- AFlags := MF_BYCOMMAND;
- {$ifdef wince}
- if FHandle <> 0 then
- {$endif wince}
- if SubMenuToInsert.FBmpItem <> 0 then
- InsertMenu( FHandle, InsertBefore, AFlags or MF_BITMAP or MF_POPUP,
- SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.FBmpItem ) )
- else
- InsertMenu( FHandle, InsertBefore, AFlags or MF_STRING or MF_POPUP,
- SubMenuToInsert.FHandle, PKOLChar( SubMenuToInsert.Caption ) );
- {$ifndef wince}
- if SubMenuToInsert.FId = 0 then
- begin
- SubMenuToInsert.FId := FDynamicMenuID;
- Inc( FDynamicMenuID );
- MII.cbSize := MenuStructSize;
- MII.fMask := MIIM_ID;
- MII.wID := SubMenuToInsert.FId;
- // {$IFNDEF UNICODE_CTRLS}
- SetMenuItemInfo( SubMenuToInsert.FParentMenu.FHandle,
- SubMenuToInsert.FParentMenu.FItems.IndexOf( SubMenuToInsert ),
- TRUE, {Windows.}PMenuItemInfo( @ MII )^ );
- // {$ELSE}
- // SetMenuItemInfoW( SubMenuToInsert.FParentMenu.FHandle,
- // SubMenuToInsert.FParentMenu.FItems.IndexOf( SubMenuToInsert ),
- // TRUE, Windows.PMenuItemInfoW( @ MII )^ );
- // {$ENDIF}
- end;
- {$endif wince}
- if (FParentMenu = nil) or (FParentMenu.FParentMenu = nil) then
- RedrawFormMenuBar;
- end;
-
- //[function TMenu.RemoveSubMenu]
- function TMenu.RemoveSubMenu( ItemToRemove: Integer ): PMenu;
- {$IFDEF DEBUG_MENU}var OK: Boolean; {$ENDIF}
- begin
- Result := Items[ ItemToRemove ];
- if Result = nil then Exit;
- {$ifdef wince}
- if Result.FHandle = 0 then
- {$endif wince}
- if Result.FParentMenu <> nil then
- {$IFDEF DEBUG_MENU} OK := {$ENDIF}
- RemoveMenu( Result.FParentMenu.FHandle, Result.FId, MF_BYCOMMAND )
- else
- {$IFDEF DEBUG_MENU} OK := {$ENDIF}
- RemoveMenu( FHandle, Result.FId, MF_BYCOMMAND );
- {$IFDEF DEBUG_MENU}
- if not OK then
- ShowMessage( 'Error removing menu: ' + Int2Str( GetLastError ) + ' - ' +
- SysErrorMessage( GetLastError ) );
- {$ENDIF}
- if Count = 0 then
- begin
- Result.Free;
- Result := nil;
- end;
- {$ifndef wince}
- RedrawFormMenuBar;
- {$endif wince}
- end;
-
- //[function TMenu.GetItemHelpContext]
- function TMenu.GetItemHelpContext(Idx: Integer): Integer;
- begin
- Result := Items[ Idx ].HelpContext;
- end;
-
- //[procedure TMenu.SetItemHelpContext]
- procedure TMenu.SetItemHelpContext(Idx: Integer; const Value: Integer);
- begin
- Items[ Idx ].HelpContext := Value;
- end;
-
- //[procedure ClearText]
- procedure ClearText( Sender: PControl );
- begin
- Sender.Caption := '';
- end;
-
- //[procedure ClearListbox]
- procedure ClearListbox( Sender: PControl );
- begin
- Sender.Perform( LB_RESETCONTENT, 0, 0 );
- end;
-
- //[procedure ClearCombobox]
- procedure ClearCombobox( Sender: PControl );
- begin
- Sender.Perform( CB_RESETCONTENT, 0, 0 );
- end;
-
- //[procedure ClearListView]
- procedure ClearListView( Sender: PControl );
- begin
- Sender.Perform( LVM_DELETEALLITEMS, 0, 0 );
- end;
-
- //[procedure ClearToolbar]
- procedure ClearToolbar( Sender: PControl );
- begin
- while Sender.TBButtonCount > 0 do
- Sender.TBDeleteButton( Sender.TBIndex2Item( 0 ) );
- Sender.Perform( TB_SETBITMAPSIZE, 0, 0 );
- end;
-
- {$ENDIF WIN_GDI}
- { -- Constructor of canvas -- }
- //[function NewCanvas]
- function NewCanvas( DC: HDC ): PCanvas;
- begin
- {-}
- New( Result, Create );
- {+}
- {++}(*
- Result := PCanvas.Create;
- *){--}
- {$IFDEF GDI}
- Result.ModeCopy := cmSrcCopy;
- if DC <> 0 then
- begin
- Result.SetHandle( DC );
- //Result.fIsPaintDC := True; // If Canvas will be destroyed, DC will not be deleted
- end;
- {$ENDIF GDI}
- end;
- //[END NewCanvas]
-
- { -- Contructors of controls -- }
-
- //[FUNCTION _NewTControl]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function _NewWindowed( AParent: PControl; ControlClassName: PKOLChar; Ctl3D: Boolean ): PControl;
- begin
- {-}
- New( Result, CreateParented( AParent ) );
- //Result.fWindowed := TRUE; // is set in TControl.Init
- {+}{++}(*Result := PControl.CreateParented( AParent );*){--}
- Result.fControlClassName := ControlClassName;
- if AParent <> nil then
- begin
- {$IFDEF WIN_GDI}
- Result.fWndProcResizeFlicks := AParent.fWndProcResizeFlicks;
- {$ENDIF WIN_GDI}
- Result.fGotoControl := AParent.fGotoControl;
- Result.fCtl3Dchild := AParent.fCtl3Dchild;
- if AParent.fCtl3Dchild then
- Result.fCtl3D := Ctl3D
- else
- Result.fCtl3D := False; //
- Result.fMargin := AParent.fMargin;
- Result.fTextColor := AParent.fTextColor;
- {$IFDEF SMALLEST_CODE}
- {$ELSE}
- {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
- Result.fFont := Result.fFont.Assign( AParent.fFont );
- if Result.fFont <> nil then
- begin
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Result.Add2AutoFree( Result.fFont );
- {$ENDIF USE_AUTOFREE4CONTROLS}
- Result.fFont.fParentGDITool := AParent.fFont;
- Result.fFont.fOnChange := Result.FontChanged;
- Result.FontChanged( Result.fFont );
- end;
- {$ENDIF WIN_GDI}
- {$ENDIF SMALLEST_CODE}
- Result.fColor := AParent.fColor;
- {$IFDEF WIN_GDI}
- Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
- if Result.fBrush <> nil then
- begin
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Result.Add2AutoFree( Result.fBrush );
- {$ENDIF USE_AUTOFREE4CONTROLS}
- Result.fBrush.fParentGDITool := AParent.fBrush;
- Result.fBrush.fOnChange := Result.BrushChanged;
- Result.BrushChanged( Result.fBrush );
- end;
- {$ENDIF WIN_GDI}
- end;
- end;
- //[END _NewWindowed]
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- var GTK_initialized: Boolean;
- argc: Integer = 0;
-
- procedure FixedChildSetPos( Ctl, Chld: PControl; x, y: Integer );
- begin
- gtk_fixed_move( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
- end;
-
- procedure LayoutChildSetPos( Ctl, Chld: PControl; x, y: Integer );
- begin
- gtk_layout_move( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
- end;
-
- procedure FixedChildPut( Ctl, Chld: PControl; x, y: Integer );
- begin
- gtk_fixed_put( GTK_FIXED( Ctl.fClient ), Chld.fEventboxHandle, x, y );
- end;
-
- procedure LayoutChildPut( Ctl, Chld: PControl; x, y: Integer );
- begin
- gtk_layout_put( GTK_LAYOUT( Ctl.fClient ), Chld.fEventboxHandle, x, y );
- end;
-
- function FixedClientArea( Ctl: PControl ): PGtkWidget;
- begin
- if Ctl.fClient = nil then
- begin
- Ctl.fClient := gtk_fixed_new;
- gtk_container_set_border_width(GTK_CONTAINER(Ctl.fHandle), 0);
- gtk_container_add( GTK_CONTAINER( Ctl.fHandle ), Ctl.fClient );
- gtk_container_set_border_width(GTK_CONTAINER(Ctl.fClient), 0);
- gtk_widget_show( Ctl.fClient );
- Ctl.fChildPut := FixedChildPut;
- Ctl.fChildSetPos := FixedChildSetPos;
- end;
- Result := Ctl.fClient;
- end;
-
- function ClientAreaLayout( Ctl: PControl ): PGtkWidget;
- begin
- if Ctl.fClient = nil then
- begin
- Ctl.fClient := gtk_layout_new( {hadjustment} nil, {vadjustment} nil );
- Ctl.fChildPut := LayoutChildPut;
- Ctl.fChildSetPos := LayoutChildSetPos;
- end;
- Result := Ctl.fClient;
- end;
-
- function _NewWindowed( AParent: PControl; ControlClassName: PChar;
- widget: PGtkWidget; need_eventbox: Boolean ): PControl;
- //var GVal: TGValue;
- begin
- (*if not GTK_initialized then
- begin
- GTK_initialized := TRUE;
- gtk_init( @ argc, {@ argv} nil );
- end;*)
- {-}
- New( Result, CreateParented( AParent, widget, need_eventbox ) );
- //Result.fWindowed := TRUE; // is set in TControl.Init
- //???//Result.fControlClassName := ControlClassName;
- if AParent <> nil then
- begin
- Result.fGotoControl := AParent.fGotoControl;
- {Result.fCtl3Dchild := AParent.fCtl3Dchild;
- if AParent.fCtl3Dchild then
- Result.fCtl3D := Ctl3D
- else
- Result.fCtl3D := False;}
- Result.fMargin := AParent.fMargin;
- Result.fTextColor := AParent.fTextColor;
- {$IFDEF SMALLEST_CODE}
- {$ELSE}
- {$IFDEF WIN_GDI} // for now Font is complicated a bit, implement it later
- Result.fFont := Result.fFont.Assign( AParent.fFont );
- if Result.fFont <> nil then
- begin
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Result.Add2AutoFree( Result.fFont );
- {$ENDIF USE_AUTOFREE4CONTROLS}
- Result.fFont.fParentGDITool := AParent.fFont;
- Result.fFont.fOnChange := Result.FontChanged;
- Result.FontChanged( Result.fFont );
- end;
- {$ENDIF WIN_GDI}
- {$ENDIF SMALLEST_CODE}
- Result.fColor := AParent.fColor;
- {$IFDEF WIN_GDI}
- Result.fBrush := Result.fBrush.Assign( AParent.fBrush );
- if Result.fBrush <> nil then
- begin
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Result.Add2AutoFree( Result.fBrush );
- {$ENDIF USE_AUTOFREE4CONTROLS}
- Result.fBrush.fParentGDITool := AParent.fBrush;
- Result.fBrush.fOnChange := Result.BrushChanged;
- Result.BrushChanged( Result.fBrush );
- end;
- {$ENDIF WIN_GDI}
- end;
- Result.fGetClientArea := FixedClientArea;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //===================== Form ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewForm]
- function NewForm( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateForm( AParent, Caption ) );
- end;
- //[END NewForm]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewForm]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewWindowed( AParent, 'Form', True );
- {$ifdef wince}
- Result.fStyle:=Result.fStyle and not WS_BORDER;
- if AParent <> nil then
- Result.fStyle:=Result.fStyle or WS_POPUP;
- {$endif wince}
- Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
- Result.AttachProc( WndProcForm );
- Result.AttachProc( WndProcDoEraseBkgnd );
- {$IFNDEF SMALLEST_CODE}
- Result.fSizeGrip := TRUE;
- {$ENDIF}
- Result.Caption := Caption;
- Result.fIsForm := TRUE;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function getFormCaption(F: PControl): KOLString;
- begin
- F.fCaption := gtk_window_get_title( GTK_WINDOW( F.fHandle ) );
- Result := F.fCaption;
- end;
-
- procedure setFormCaption(F: PControl; const Value: KOLString);
- begin
- F.fCaption := Value;
- gtk_window_set_title( GTK_WINDOW( F.fCaptionHandle ), PChar( String( Value ) ) );
- end;
-
- procedure DestroyForm( Widget: PGtkWidget; Sender: PControl ); cdecl;
- var Quit: Boolean;
- begin
- Quit := Sender.IsMainWindow;
- Sender.Free;
- if Quit then
- gtk_main_quit();
- end;
-
- function NewForm( AParent: PControl; const Caption: KOLString ): PControl;
- {$IFDEF GTK}
- var widget: PGtkWidget;
- {$ENDIF GTK}
- begin
- if not GTK_initialized then
- begin
- GTK_initialized := TRUE;
- gtk_init( @ argc, {@ argv} nil );
- end;
- {$IFDEF GDI}
- Result := _NewWindowed( AParent, 'Form', True );
- {$ELSE _X_}
- {$IFDEF GTK}
- widget := gtk_window_new( GTK_WINDOW_TOPLEVEL );
- Result := _NewWindowed( AParent, 'Form', widget, FALSE );
- {$ENDIF GTK}
- {$ENDIF _X_}
- Result.fGetCaption := getFormCaption;
- Result.fSetCaption := setFormCaption;
- Result.Caption := Caption;
- Result.fIsForm := TRUE;
- gtk_signal_connect( Pointer( Result.fHandle ), 'destroy',
- @ DestroyForm, Result );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- //[END NewForm]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- //===================== Applet button ========================//
-
- //[FUNCTION WndProcApp]
- {$IFDEF ASM_VERSION}
- function WndProcAppAsm(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- asm
- CMP word ptr [EDX].TMsg.message, WM_SETFOCUS
- JNZ @@chk_CLOSE
- MOV ECX, [EAX].TControl.FCurrentControl
- JECXZ @@ret_false
- XCHG EAX, ECX
- PUSH EAX
- CALL CallTControlCreateWindow
- TEST AL, AL
- POP EAX
- JZ @@1
- PUSH [EAX].TControl.fHandle
- CALL SetFocus
- @@1: MOV AL, 1
- RET
- @@chk_CLOSE:
- CMP word ptr [EDX].TMsg.message, WM_SYSCOMMAND
- JNZ @@ret_false
- MOV EDX, dword ptr [EDX].TMsg.wParam
- AND DX, $FFF0
- CMP DX, SC_CLOSE
- JNZ @@ret_false
- PUSH ECX
- MOV ECX, [EAX].TControl.fChildren
- JECXZ @@ret_false1
- XCHG EAX, ECX
- MOV ECX, [EAX].TList.fCount
- JECXZ @@ret_false1
- MOV EAX, [EAX].TList.fItems
- MOV ECX, dword ptr [EAX]
- JECXZ @@ret_false1
- XCHG EAX, ECX
- PUSH EAX
- CALL TControl.IsMainWindow
- TEST EAX, EAX
- POP EAX
- JZ @@ret_false1
- CALL TControl.Close
- POP ECX
- XOR EAX, EAX
- MOV dword ptr [ECX], EAX
- INC EAX
- JMP @@exit
- @@ret_false1:
- POP ECX
- @@ret_false:
- XOR EAX, EAX
- @@exit:
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcAppPas(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- begin
- Result := False;
- case Msg.message of
- WM_SETFOCUS:
- {$IFDEF NEW_MODAL}
- if Self_.fModalForm <> nil then
- SetFocus( Self_.fModalForm.fHandle )
- else if ( Self_.FCurrentControl <> nil ) and not
- ( Self_.fCurrentControl.IsForm xor Self_.fIsApplet ) then
- {$ELSE not_NEW_MODAL}
- if Self_.FCurrentControl <> nil then
- {$ENDIF NEW_MODAL}
- begin
- if Self_.FCurrentControl.CreateWindow then
- SetFocus( Self_.FCurrentControl.fHandle );
- Result := True;
- end;
- WM_SYSCOMMAND:
- CASE Msg.wParam and $FFF0 OF
- SC_CLOSE:
- if (Self_.fChildren <> nil) and (Self_.fChildren.fCount > 0) and
- PControl( Self_.fChildren.fItems[ 0 ] ).IsMainWindow then
- begin
- PControl( Self_.fChildren.fItems[ 0 ] ).Close;
- Rslt := 0;
- Result := TRUE;
- end;
- END;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcApp]
-
- {$IFDEF USE_CONSTRUCTORS}
- {$DEFINE CREATEAPPBUTTON_USED}
- //[function NewApplet]
- function NewApplet( const Caption: String ): PControl;
- begin
- new( Result, CreateApplet( Caption ) );
- end;
- //[END NewApplet]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewApplet]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
-
- //[procedure CreateAppButton]
- {$ifdef win32}
- procedure CreateAppButton( App: PControl );
- var M: HMenu;
- begin
- M := GetSystemMenu( App.fHandle, False );
- DeleteMenu( M, SC_MAXIMIZE, MF_BYCOMMAND );
- DeleteMenu( M, SC_MOVE, MF_BYCOMMAND );
- DeleteMenu( M, SC_SIZE, MF_BYCOMMAND );
- EnableMenuItem( M, SC_RESTORE, MF_GRAYED or MF_BYCOMMAND );
- end;
- {$endif win32}
-
- //[function NewApplet]
- function NewApplet( const Caption: KOLString ): PControl;
- begin
- AppButtonUsed := True;
- Result := _NewWindowed( nil, 'App', True );
- Result.FIsApplet := TRUE;
- {$ifdef wince}
- Result.fStyle := WS_VISIBLE;
- {$else}
- Result.fStyle := DWORD(WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX or WS_CAPTION);
- Result.fExStyle := WS_EX_APPWINDOW;
- Result.FCreateWndExt := CreateAppButton;
- {$endif wince}
- {$IFDEF ASM_VERSION}
- Result.AttachProc( WndProcAppAsm );
- {$ELSE}
- Result.AttachProc( WndProcAppPas );
- {$ENDIF}
- Result.Caption := Caption;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewApplet]
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF CREATEAPPBUTTON_USED}
- procedure CreateAppButton( App: PControl );
- asm
- {$IFDEF F_P}
- MOV EAX, [App]
- {$ENDIF F_P}
- PUSH ESI
- PUSH 0
- PUSH [EAX].TControl.fHandle
- CALL GetSystemMenu
- MOV ESI, offset[DeleteMenu]
-
- XCHG ECX, EAX
- MOV EAX, SC_MAXIMIZE
- CDQ
-
- PUSH EDX
- PUSH EAX
- PUSH ECX
-
- PUSH EDX
- {$IFDEF PARANOIA} DB $2C, $20 {$ELSE} SUB AL, $20 {$ENDIF} // SC_MOVE
- PUSH EAX
- PUSH ECX
-
- PUSH EDX
- {$IFDEF PARANOIA} DB $2C, $10 {$ELSE} SUB AL, $10 {$ENDIF} // SC_SIZE
- PUSH EAX
- PUSH ECX
-
- PUSH 1 // MF_GRAYED or MF_BYCOMMAND
- MOV AX, SC_RESTORE
- PUSH EAX
- PUSH ECX
-
- CALL EnableMenuItem
- CALL ESI
- CALL ESI
- CALL ESI
- POP ESI
- end {$IFDEF F_P} [ 'EAX', 'EDX', 'ECX' ] {$ENDIF};
- {$ENDIF CREATEAPPBUTTON_USED}
-
- var CtlIdCount: WORD = $8000;
-
- {-}
- {$IFNDEF ASM_VERSION}
- //{$DEFINE CREATEPARAMS2_USED}
- {$ENDIF}
- {$IFDEF USE_CONSTRUCTORS}
- //{$DEFINE CREATEPARAMS2_USED}
- {$ENDIF}
- {+}
-
- {$IFDEF CREATEPARAMS2_USED} // seems not needed more
- //[procedure CreateParams2]
- procedure CreateParams2( Self_: PControl; var Params: TCreateParams);
- begin
- Self_.CreateSubclass( Params, Self_.fControlClassName );
- end;
- {$ENDIF}
-
- {$ENDIF WIN_GDI}
-
- //[FUNCTION _NewControl]
- {$IFDEF GDI}
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function _NewControl( AParent: PControl; ControlClassName: PKOLChar;
- Style: DWORD; Ctl3D: Boolean; Actions: PCommandActions ): PControl;
- var Form: PControl;
- begin
- Result := _NewWindowed( AParent, ControlClassName, Ctl3D );
- if Actions <> nil then
- Result.fCommandActions := Actions^;
- Result.fIsControl := True;
- Result.fStyle := Style or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
- Result.fVerticalAlign := vaTop;
- Result.fVisible := (Style and WS_VISIBLE) <> 0;
- Result.fTabstop := (Style and WS_TABSTOP) <> 0;
- if (AParent <> nil) then
- begin
- with Result.fBoundsRect do
- begin
- Left := AParent.fMargin + AParent.fClientLeft;
- Top := AParent.fMargin + AParent.fClientTop;
- Right := Left + 64;
- Bottom := Top + 64;
- end;
- Inc( AParent.ParentForm.fTabOrder );
- Result.fTabOrder := AParent.ParentForm.fTabOrder;
- Result.fCursor := AParent.fCursor;
- end;
- Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
- {$ifdef win32}
- if Result.fCtl3D then
- begin
- Result.fStyle := Result.fStyle and not WS_BORDER;
- Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
- end;
- {$endif win32}
- if (Style and WS_TABSTOP) <> 0 then
- begin
- Form := Result.ParentForm;
- if Form <> nil then
- if Form.FCurrentControl = nil then
- Form.FCurrentControl := Result;
- end;
- Result.fMenu := CtlIdCount;
- Inc( CtlIdCount );
- Result.AttachProc( WndProcCtrl );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function getLabelCaption( L: PControl ): KOLString;
- begin
- L.fCaption := gtk_label_get_text( Pointer( L.fCaptionHandle ) );
- Result := L.fCaption;
- end;
-
- procedure setLabelCaption( L: PControl; const Value: KOLString );
- begin
- L.fCaption := Value;
- gtk_label_set_text( Pointer( L.fCaptionHandle ), PChar( String( Value ) ) );
- end;
-
- function _NewControl( AParent: PControl; ControlClassName: PChar;
- Style: DWORD; Ctl3D: Boolean; widget: PGtkWidget; need_eventbox: Boolean ): PControl;
- var Rect: TRect;
- begin
- Result := _NewWindowed( AParent, ControlClassName, widget, need_eventbox );
- Result.fIsControl := True;
- Result.fVerticalAlign := vaTop;
- Result.{todo: remove f}fVisible := (Style and WS_VISIBLE) <> 0;
- Result.fTabstop := (Style and WS_TABSTOP) <> 0;
- if (AParent <> nil) then
- begin
- with Rect do
- begin
- Left := AParent.fMargin + AParent.fClientLeft;
- Top := AParent.fMargin + AParent.fClientTop;
- end;
- Inc( AParent.ParentForm.fTabOrder );
- Result.fTabOrder := AParent.ParentForm.fTabOrder;
- {$IFDEF GDI}
- Result.fCursor := AParent.fCursor;
- {$ENDIF GDI}
- //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), Result.fHandle );
- end;
- {with Rect do
- begin
- Right := Left + 64;
- Bottom := Top + 64;
- end;
- Result.fBoundsRect := Result.BoundsRect;
- Result.BoundsRect := Rect;}
- Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
- {$IFDEF GDI}
- if Result.fCtl3D then
- begin
- Result.fStyle := Result.fStyle and not WS_BORDER;
- Result.fExStyle := Result.fExStyle or WS_EX_CLIENTEDGE;
- end;
- if (Style and WS_TABSTOP) <> 0 then
- begin
- Form := Result.ParentForm;
- if Form <> nil then
- if Form.FCurrentControl = nil then
- Form.FCurrentControl := Result;
- end;
- Result.fMenu := CtlIdCount;
- Inc( CtlIdCount );
- Result.AttachProc( WndProcCtrl );
- {$ENDIF GDI}
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- //[END _NewControl]
-
- {$IFDEF WIN_GDI}
-
- //===================== Button ========================//
-
- //[function TControl.SetButtonIcon]
- function TControl.SetButtonIcon(aIcon: HIcon): PControl;
- var PrevImg: THandle;
- begin
- Style := Style or BS_ICON;
- fButtonIcon := aIcon;
- PrevImg := Perform( BM_SETIMAGE, IMAGE_ICON, aIcon );
- if PrevImg <> 0 then
- DeleteObject( PrevImg );
- Result := @ Self;
- end;
-
- //[function TControl.SetButtonBitmap]
- function TControl.SetButtonBitmap(aBmp: HBitmap): PControl;
- var PrevImg: THandle;
- begin
- Style := Style or BS_BITMAP;
- PrevImg := Perform( BM_SETIMAGE, IMAGE_BITMAP, aBmp );
- if PrevImg <> 0 then
- DeleteObject( PrevImg );
- Result := @ Self;
- end;
-
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- //[function WndProcBtnReturnClick]
- function WndProcBtnReturnClick( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
- (Msg.message = WM_CHAR)) and (Msg.wParam = 13) then
- Msg.wParam := 32;
- end;
- {$ENDIF}
-
- {$IFNDEF BUTTON_DBLCLICK}
- //[function WndProcBtnDblClkAsClk]
- function WndProcBtnDblClkAsClk( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if Msg.message = WM_LBUTTONDBLCLK then
- Msg.message := WM_LBUTTONDOWN;
- end;
- {$ENDIF}
-
- {$ifdef wince}
- function WndProcBtnFocus( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- case Msg.message of
- WM_SETFOCUS:
- Sender.Style:=Sender.Style or BS_DEFPUSHBUTTON;
- WM_KILLFOCUS:
- Sender.Style:=Sender.Style and not BS_DEFPUSHBUTTON;
- end;
- end;
- {$endif wince}
-
- //[function AutoMinimizeApplet]
- function AutoMinimizeApplet(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- begin
- if (msg.Message=WM_SYSCOMMAND) and ((msg.wParam and not 15)=SC_MINIMIZE) then begin
- AppletMinimize;
- Result := True;
- end else
- Result := False;
- end;
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewButton]
- function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- new( Result, CreateButton( AParent, Caption ) );
- end;
- {$ELSE USE_CONSTRUCTORS}
-
- {$IFDEF ASM_VERSION}
- const ButtonClass: array[ 0..6 ] of KOLChar = ( 'B','U','T','T','O','N',#0 );
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION NewButton]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewControl( AParent, 'BUTTON',
- WS_VISIBLE or WS_CHILD or BS_NOTIFY or
- BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions );
- {$ifdef wince}
- Result.fColor:=clBtnFace;
- if Result.fBrush <> nil then
- Result.fBrush.fData.Color:=Result.fColor;
- {$endif wince}
- {$IFDEF BUTTON_DBLCLICK}
- Result.ClsStyle := Result.ClsStyle - CS_DBLCLKS;
- {$ENDIF}
- Result.fIgnoreDefault := TRUE;
- //Result.fCtl3D := TRUE;
- with Result.fBoundsRect do
- Bottom := Top + 22;
- Result.fTextAlign := taCenter;
- Result.Caption := Caption;
- Result.fIsButton := TRUE;
- {$IFNDEF SMALLEST_CODE}
- {$IFNDEF BUTTON_DBLCLICK}
- Result.AttachProc( WndProcBtnDblClkAsClk );
- {$ENDIF}
- {$ENDIF}
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- Result.AttachProc( WndProcBtnReturnClick );
- {$ENDIF}
- {$ifdef wince}
- Result.AttachProc(WndProcBtnFocus);
- {$endif wince}
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_BitBtn(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewButton]
-
- {$ENDIF USE_CONSTRUCTORS}
- {$ENDIF WIN_GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- const
- HorAlignments: array[ TTextAlign ] of Single = ( {taLeft} 0, {taRight} 1, {taCenter} 0.5 );
- VerAlignments: array[ TVerticalAlign ] of Single = ( {vaCenter} 0.5, {vaTop} 0, {vaBottom} 1 );
-
- procedure ButtonSetTextAlign( Self_: PControl );
- begin
- gtk_button_set_alignment( GTK_BUTTON( Self_.fHandle ), HorAlignments[ Self_.fTextAlign ],
- VerAlignments[ Self_.fVerticalAlign ] );
- end;
-
- function NewButton( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewControl( AParent, 'BUTTON',
- WS_VISIBLE or WS_CHILD or BS_NOTIFY or
- BS_PUSHLIKE or WS_TABSTOP, False,
- gtk_button_new{_with_label}( {PChar( String( Caption ) )} ), FALSE );
- //Result.Height := 22;
- gtk_container_set_border_width( GTK_CONTAINER( Result.fHandle ), 0 );
- Result.fCaptionHandle := gtk_label_new( PChar( String( Caption ) ) );
- gtk_container_add( GTK_CONTAINER( Result.fHandle ), Result.fCaptionHandle );
- //gtk_container_set_border_width( GTK_CONTAINER( Result.fCaptionHandle ), 0 );
- gtk_widget_show( Result.fCaptionHandle );
- Result.fGetCaption := getLabelCaption;
- Result.fSetCaption := setLabelCaption;
- //Result.fIgnoreDefault := TRUE;
- //Result.fCtl3D := TRUE;
- //with Result.fBoundsRect do
- // Bottom := Top + 22;
- Result.fTextAlign := taCenter;
- Result.fCaption := Caption;
- Result.fIsButton := TRUE;
- Result.fSetTextAlign := ButtonSetTextAlign;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //----------------- BitBtn -----------------------
-
- //[FUNCTION WndProc_DrawItem]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProc_DrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var DI: PDrawItemStruct;
- Control: PControl;
- begin
- Result := FALSE;
- if Msg.message = WM_DRAWITEM then
- begin
- DI := Pointer( Msg.lParam );
- {$IFDEF USE_PROP}
- Control := Pointer( GetProp( DI.hwndItem, ID_SELF ) );
- {$ELSE}
- Control := Pointer( GetWindowLong( DI.hwndItem, GWL_USERDATA ) );
- {$ENDIF}
- if Control <> nil then
- begin
- Rslt := Control.Perform( CN_DRAWITEM, Msg.wParam, Msg.lParam );
- Result := TRUE;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProc_DrawItem]
-
- //[function ExcludeAmpersands]
- function ExcludeAmpersands( Self_: PControl; const S: String ): String;
- var I: Integer;
- begin
- Result := S;
- if not Self_.FBitBtnDrawMnemonic then Exit;
- for I := Length( Result ) downto 1 do
- begin
- if Result[ I ] = '&' then
- Delete( Result, I, 1 );
- end;
- end;
-
- //[procedure BitBtnExtDraw]
- procedure BitBtnExtDraw( Self_: PControl; DC: HDC; X, Y: Integer; const R: TRect;
- const CapText, CapTxtOrig: KOLString; Color: TColor );
- var I, J, W, H: Integer;
- Sz: TSize;
- Pen, OldPen: HPen;
- begin
- if not Self_.FBitBtnDrawMnemonic then Exit;
- J := 0;
- for I := 1 to Length( CapTxtOrig ) do
- begin
- if CapTxtOrig[ I ] <> '&' then
- Inc( J )
- else
- begin
- GetTextExtentPoint32( DC, PKOLChar( CapText ), J, Sz );
- W := Sz.cx;
- Windows.GetTextExtentPoint32( DC, '_', 1, Sz );
- H := Sz.cy - 1;
- Windows.GetTextExtentPoint32( DC, @ CapTxtOrig[ I + 1 ], 1, Sz );
- Windows.MoveToEx( DC, X + W, Y + H, nil );
-
- Pen := CreatePen( PS_SOLID, 0, Color2RGB( Color ) );
- OldPen := SelectObject( DC, Pen );
-
- Windows.LineTo( DC, X + W + Sz.cx, Y + H );
-
- SelectObject( DC, OldPen );
- DeleteObject( Pen );
- end;
- end;
- end;
-
- //[procedure TControl.SetBitBtnDrawMnemonic]
- procedure TControl.SetBitBtnDrawMnemonic(const Value: Boolean);
- begin
- FBitBtnDrawMnemonic := Value;
- FBitBtnGetCaption := ExcludeAmpersands;
- FBitBtnExtDraw := BitBtnExtDraw;
- Invalidate;
- end;
-
- //[function TControl.GetBitBtnImgIdx]
- function TControl.GetBitBtnImgIdx: Integer;
- begin
- Result := LoWord( fGlyphCount );
- end;
-
- //[procedure TControl.SetBitBtnImgIdx]
- procedure TControl.SetBitBtnImgIdx(const Value: Integer);
- begin
- if not( bboImageList in fBitBtnOptions ) then Exit;
- fGlyphCount := HiWord( fGlyphCount ) or (Value and $FFFF);
- Invalidate;
- end;
-
- //[function TControl.GetBitBtnImageList]
- function TControl.GetBitBtnImageList: THandle;
- begin
- Result := 0;
- if bboImageList in fBitBtnOptions then
- Result := fGlyphBitmap;
- end;
-
- //[procedure TControl.SetBitBtnImageList]
- procedure TControl.SetBitBtnImageList(const Value: THandle);
- begin
- fGlyphBitmap := Value;
- if Value <> 0 then
- begin
- fBitBtnOptions := fBitBtnOptions + [ bboImageList ];
- ImageList_GetIconSize( Value, fGlyphWidth, fGlyphHeight );
- end
- else
- fBitBtnOptions := fBitBtnOptions - [ bboImageList ];
- Invalidate;
- end;
-
- //[FUNCTION WndProcBitBtn]
- {$IFDEF ASM_noVERSION} // remove &-s from view //+ TextShift & if Y < 0 then Y := 0; // + glyph + TextShift if not glyphOver
- // timer when RepeatInterval set
- function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- const szBitmapInfo = sizeof(TBitmapInfo);
- asm
- CMP word ptr [EDX].TMsg.message, WM_LBUTTONDBLCLK
- JNZ @@noWM_LBUTTONDBLCLK
- PUSH ECX
- PUSH [EDX].TMsg.wParam
- PUSH [EDX].TMsg.lParam
- PUSH WM_LBUTTONDOWN
- PUSH EAX
- CALL TControl.Perform
- POP ECX
- MOV [ECX], EAX
- MOV AL, 1
- RET
- @@noWM_LBUTTONDBLCLK:
- PUSH EBX
- CMP [EDX].TMsg.message, CN_DRAWITEM
- JNZ @@noCN_DRAWITEM
- PUSH EDI
- PUSH ESI
- XCHG EDI, EAX // EDI = @Self
- MOV dword ptr [ECX], 1
- MOV ESI, [EDX].TMsg.lParam // ESI = DIS
- XOR EBX, EBX // G = 0
- MOV EAX, [ESI].TDrawItemStruct.itemState
- TEST byte ptr [EDI].TControl.fBitBtnOptions, 8 //1 shl Ord(bboFixed)
- JNZ @@fixed_in_options
- {$IFDEF PARANOIA} DB $A8, ODS_SELECTED {$ELSE} TEST AL, ODS_SELECTED {$ENDIF}
- JZ @@not1
- JMP @@1
- @@fixed_in_options:
- TEST byte ptr [EDI].TControl.fChecked, 1
- JZ @@not1
- @@1: INC EBX
- @@not1:
- {$IFDEF PARANOIA} DB $A8, ODS_DISABLED {$ELSE} TEST AL, ODS_DISABLED {$ENDIF}
- JZ @@not2
- MOV BL, 2
- @@not2: TEST EBX, EBX
- JNZ @@not3
- {$IFDEF PARANOIA} DB $A8, ODS_FOCUS {$ELSE} TEST AL, ODS_FOCUS {$ENDIF}
- JZ @@not3
- MOV BL, 3
- @@not3: CMP [EDI].TControl.fMouseInControl, BH
- JZ @@not4
- TEST EBX, EBX
- JZ @@4
- CMP BL, 3
- JNZ @@not4
- @@4: MOV BL, 4
- @@not4: MOV ECX, [EDI].TControl.fOnBitBtnDraw.TMethod.Code
- TEST ECX, ECX
- JZ @@noOnBitBtnDraw
- //JECXZ @@noOnBitBtnDraw
- MOV EAX, [EDI].TControl.fCanvas
- PUSH EAX
- TEST EAX, EAX
- JZ @@noCanvas
- MOV EDX, [ESI].TDrawItemStruct.hDC
- CALL TCanvas.SetHandle
- @@noCanvas:
- MOV EAX, [EDI].TControl.fOnBitBtnDraw.TMethod.Data
- MOV EDX, EDI
- PUSH EBX
- XCHG ECX, EBX
- CALL EBX
- POP EBX
- POP ECX // Canvas
- PUSH EAX
- JECXZ @@noCanvas2
- XCHG EAX, ECX
- XOR EDX, EDX
- CALL TCanvas.SetHandle
- @@noCanvas2:
- POP EAX
- TEST AL, AL
- JNZ @@exit_draw
- @@noOnBitBtnDraw:
- TEST byte ptr [EDI].TControl.fBitBtnOptions, 2 //1 shl Ord(bboNoBorder)
- JNZ @@noborder
- TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS
- JZ @@noDefaultBorder
- PUSH {BLACK_BRUSH} DKGRAY_BRUSH
- CALL GetStockObject
- LEA EDX, [ESI].TDrawItemStruct.rcItem
- OR ECX, -1
- PUSH ECX
- PUSH ECX
- PUSH EDX
- PUSH EAX
- PUSH EDX
- PUSH [ESI].TDrawItemStruct.hDC
- CALL Windows.FrameRect
- CALL InflateRect
- XOR ECX, ECX
- JMP @@noFlat
- @@noDefaultBorder:
- MOVZX ECX, [EDI].TControl.fFlat
- JECXZ @@noFlat
- AND CL, [EDI].TControl.fMouseInControl
- JZ @@noborder
- @@noFlat:
- TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_SELECTED
- MOV CL, {BDR_SUNKENOUTER or} BDR_SUNKENINNER
- JNZ @@border_sunken
- MOV CL, {BDR_RAISEDOUTER or} BDR_RAISEDINNER
- @@border_sunken:
- LEA EDX, [ESI].TDrawItemStruct.rcItem
- OR EAX, -1
- PUSH EAX
- PUSH EAX
- PUSH EDX
- PUSH BF_ADJUST or BF_RECT
- PUSH ECX
- PUSH EDX
- PUSH [ESI].TDrawItemStruct.hDC
- CALL DrawEdge
- CALL InflateRect
- @@noborder:
- PUSH [ESI].TDrawItemStruct.rcItem.Bottom
- PUSH [ESI].TDrawItemStruct.rcItem.Right
- PUSH [ESI].TDrawItemStruct.rcItem.Top
- PUSH [ESI].TDrawItemStruct.rcItem.Left
- MOV EAX, [EDI].TControl.fGlyphWidth
- MOV EDX, [EDI].TControl.fGlyphHeight
- TEST EAX, EAX
- JLE @@noglyph
- TEST EDX, EDX
- JLE @@noglyph
- PUSH EBP
- MOV EBP, ESP
-
- PUSH EDX // ImgH -> [EBP-4]
- PUSH EAX // ImgW -> [EBP-8]
- PUSH EDX // OutH -> [EBP-12]
- PUSH EAX // OutW -> [EBP-16]
- MOV EAX, [ESI].TDrawItemStruct.rcItem.Left // X = DIS.rcItem.Left
- MOV EDX, [ESI].TDrawItemStruct.rcItem.Top // Y = DIS.rcItem.Top
- MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom
- SUB ECX, EDX
- PUSH ECX // H -> [EBP-20]
- MOV ECX, [ESI].TDrawItemStruct.rcItem.Right
- SUB ECX, EAX
- PUSH ECX // W -> [EBP-24]
- MOVZX ECX, [EDI].TControl.fGlyphLayout
- PUSH EBX
- INC ECX
- LOOP @@noGlyphLeft
- MOV EBX, EAX // X
- ADD EBX, [EBP-16] // +OutW
- MOV [EBP+4].TRect.Left, EBX // TxRect.Left = X+OutW
- JMP @@centerY
- @@noGlyphLeft:
- LOOP @@noGlyphTop
- MOV EBX, EDX // Y
- ADD EBX, [EBP-12] // +OutH
- MOV [EBP+4].TRect.Top, EBX // TxRect.Top = Y+OutH
- LOOP @@centerX // always JMP, ECX := -1
- @@noGlyphTop:
- LOOP @@noGlyphRight
- MOV EAX, [ESI].TDrawItemStruct.rcItem.Right
- SUB EAX, [EBP-16] // -OutW -> X
- MOV [EBP+4].TRect.Right, EAX
- @@centerY:
- MOV EBX, [EBP-20] // H
- SUB EBX, [EBP-12] // -OutH
- JLE @@noGlyphRight
- SAR EBX, 1
- ADD EDX, EBX // Y = Y + (H-OutH)/2
- @@noGlyphRight:
- LOOP @@noGlyphBottom
- MOV EDX, [ESI].TDrawItemStruct.rcItem.Bottom
- SUB EDX, [EBP-12] // -OutH -> Y
- MOV [EBP+4].TRect.Bottom, EDX
- LOOP @@centerX // always JMP, ECX := -1
- @@noGlyphBottom:
- LOOP @@noGlyphOver
- @@centerX:
- MOV EBX, [EBP-24] // W
- SUB EBX, [EBP-16] // -OutW
- SHR EBX, 1 // /2
- ADD EAX, EBX // +EAX, X = X + (W-OutW)/2
- JECXZ @@centerY
- @@noGlyphOver:
- MOV ECX, [ESI].TDrawItemStruct.rcItem.Left
- CMP EAX, ECX
- JGE @@ok1
- XCHG EAX, ECX
- @@ok1: CMP EDX, [ESI].TDrawItemStruct.rcItem.Top
- {$IFDEF USE_CMOV}
- CMOVL EDX, [ESI].TDrawItemStruct.rcItem.Top
- {$ELSE}
- JGE @@ok2
- MOV EDX, [ESI].TDrawItemStruct.rcItem.Top
- @@ok2: {$ENDIF}
-
- MOV ECX, [ESI].TDrawItemStruct.rcItem.Right
- SUB ECX, EAX
- CMP [EBP-16], ECX
- JLE @@ok3
- MOV [EBP-16], ECX // OutW := rcItem.Right - X;
- @@ok3: MOV ECX, [ESI].TDrawItemStruct.rcItem.Bottom
- SUB ECX, EDX
- CMP ECX, [EBP-12]
- JGE @@ok4
- MOV [EBP-12], ECX // OutH := rcItem.Bottom - Y;
- @@ok4:
- POP EBX // EBX = G
- TEST byte ptr [EDI].TControl.fBitBtnOptions, 1 //1 shl Ord(bboImageList)
- JZ @@draw_bitmap
- MOVZX ECX, word ptr [EDI].TControl.fGlyphCount
- CMP word ptr [EDI].TControl.fGlyphCount + 2, BX
- JLE @@no_add_glyphIdx
- ADD ECX, EBX
- @@no_add_glyphIdx:
- XOR EBX, EBX
- PUSH ILD_TRANSPARENT // Flags = 1 (ILD_TRANSPARENT)
- PUSH EBX // Blend = 0
- PUSH -1 // Bk = CLR_NONE
- PUSH EBX // 0
- PUSH EBX // 0
- PUSH EDX
- PUSH EAX
- PUSH [ESI].TDrawItemStruct.hDC
- PUSH ECX
- PUSH [EDI].TControl.fGlyphBitmap
- CMP [EDI].TControl.fTransparent, BL
- JNZ @@imgl_transp
- MOV EAX, [EDI].TControl.fColor
- CALL Color2RGB
- MOV [ESP+32], EAX // Bk = Color2RGB(fColor)
- MOV [ESP+40], EBX // Flags = 0
- @@imgl_transp:
- INC EBX
- CMP word ptr [EDI].TControl.fGlyphCount + 2, BX
- JNZ @@draw_imagelist
- DEC byte ptr [ESP+36+3] // $FF, CLR_DEFAULT = $FF000000
- TEST byte ptr [ESI].TDrawItemStruct.itemState, ODS_FOCUS
- JZ @@draw_imagelist
- OR byte ptr [ESP+40], ILD_BLEND25 // Flags != 2
- @@draw_imagelist:
- CALL ImageList_DrawEx
- JMP @@glyph_drawn
-
- @@draw_bitmap:
- PUSH EAX // PlaceHold for DC
- PUSH EAX // PlaceHold for OldBmp
- PUSH SRCCOPY
- PUSH dword ptr [EBP-4] // ImgH
- PUSH dword ptr [EBP-8] // ImgW
- PUSH 0
- PUSH EAX // PlaceHold for I
- PUSH EAX // PlaceHold for DC
- PUSH dword ptr [EBP-12] // OutH
- PUSH dword ptr [EBP-16] // OutW
- PUSH EDX // Y
- PUSH EAX // X
- PUSH [ESI].TDrawItemStruct.hDC
-
- PUSH 0
- CALL CreateCompatibleDC
- MOV [ESP+48], EAX // save DC
- MOV [ESP+20], EAX // place DC
- PUSH [EDI].TControl.fGlyphBitmap
- PUSH EAX
- CALL SelectObject
- MOV [ESP+44], EAX // save OldBitmap
- XOR EAX, EAX
- CMP [EDI].TControl.fGlyphCount, EBX
- JLE @@no_incGlyIdx
- MOV EAX, [EBP-8] // ImgW
- IMUL EBX
- @@no_incGlyIdx:
- MOV [ESP+24], EAX // place I
- CALL StretchBlt
- CALL FinishDC
-
- @@glyph_drawn:
- MOV ESP, EBP
- POP EBP
-
- @@noglyph:
- TEST byte ptr[EDI].TControl.fBitBtnOptions, 4 //1 shl Ord(bboNoCaption)
- JNZ @@noCaption
-
- POP EAX
- PUSH EAX
- MOV EDX, [ESP].TRect.Right
- CMP EDX, EAX
- JLE @@noCaption
- MOV EDX, [ESP].TRect.Bottom
- CMP EDX, [ESP].TRect.Top
- JLE @@noCaption
-
- XOR EBX, EBX
- PUSH EBX // > CapText
- MOV EDX, ESP
- MOV EAX, EDI
- CALL TControl.GetCaption
- PUSH EBX // > Bk
- PUSH EBX // > Blend
- CMP [EDI].TControl.fTransparent, BL
- MOV BL, ETO_CLIPPED
- JNZ @@drwTxTransparent
- CMP [EDI].TControl.fGlyphLayout, glyphOver
- JNZ @@drwTxOpaque
- @@drwTxTransparent:
- PUSH TRANSPARENT
- PUSH [ESI].TDrawItemStruct.hDC
- CALL SetBkMode
- MOV [ESP+4], EAX // Bk := SetBkMode( DIS.hDC, TRANSPARENT )
- JMP @@drwTx1
- @@drwTxOpaque:
- MOV BL, ETO_CLIPPED or ETO_OPAQUE
- MOV EAX, [EDI].TControl.fColor
- CALL Color2RGB
- PUSH EAX
- PUSH [ESI].TDrawItemStruct.hDC
- CALL SetBkColor
- POP ECX
- PUSH EAX // Blend := SetBkColor(DIS.hDC,fColor)
- @@drwTx1:
- PUSH 0 // > OldFont
- PUSH 0 // > OldTextColor
-
- PUSH 0 // push <nil>
- MOV EDX, [ESP+20] // CapText
- CALL EDX2PChar
- PUSH dword ptr [EDX-4] // push Length(CapText)
- PUSH EDX // push PChar(CapText)
- LEA EAX, [ESP+32]
- PUSH EAX // push @TxRect
- PUSH EBX // push Flags
-
- MOV EBX, [ESI].TDrawItemStruct.hDC
-
- MOV ECX, [EDI].TControl.fFont
- JECXZ @@drwTx_noFont
- XCHG EAX, ECX
- CALL TGraphicTool.GetHandle
- PUSH EAX
- PUSH EBX
- CALL SelectObject
- MOV [ESP+24], EAX // OldFont := SelectObject...
- @@drwTx_noFont:
- MOV EAX, [EDI].TControl.fTextColor
- CALL Color2RGB
- PUSH EAX
- PUSH EBX
- CALL SetTextColor
- MOV [ESP+20], EAX // OldTextColor := SetTextColor...
-
- PUSH EAX
- PUSH EAX
- PUSH ESP
- MOV ECX, [ESP+48] // ECX = CapText
- XOR EAX, EAX
- JECXZ @@drwTx0
- MOV EAX, [ECX-4] // EAX = Length(CapText)
- @@drwTx0:
- PUSH EAX
- PUSH ECX
- PUSH EBX
- CALL GetTextExtentPoint32
- POP ECX // ECX = TextSz.cx
- POP EDX // EDX = TextSz.cy
- MOV EAX, [ESP+40].TRect.Bottom
- SUB EAX, [ESP+40].TRect.Top
- SUB EAX, EDX
- JGE @@yOk
- XOR EAX, EAX
- @@yOk: SHR EAX, 1
- ADD EAX, [ESP+40].TRect.Top
- PUSH EAX // push Y
- MOV EDX, [ESP+44].TRect.Right
- MOV EAX, [ESP+44].TRect.Left // EAX = TxRect.Left
- SUB EDX, EAX // EDX = W
- PUSH EAX
- CMP [EDI].TControl.fTextAlign, taRight
- JL @@chk_X
- JE @@alignR
- SUB ECX, EDX
- SAR ECX, 1
- JMP @@alignC
- @@alignR:
- ADD EAX, EDX
- @@alignC:
- SUB EAX, ECX
- @@chk_X:POP EDX
- CMP EAX, EDX
- JGE @@xOk
- XCHG EAX, EDX
- @@xOk: PUSH EAX // push X
- PUSH EBX // push hDC
- CALL ExtTextOut
-
- PUSH EBX
- CALL SetTextColor
- POP ECX
- JECXZ @@noRestoreFont
- PUSH ECX
- PUSH EBX
- CALL SelectObject
- @@noRestoreFont:
- POP ECX // Blend
- JECXZ @@restoreBk
- PUSH ECX
- PUSH EBX
- CALL SetBkColor
- POP ECX
- JMP @@delCaption
- @@restoreBk:
- PUSH EBX
- CALL SetBkMode
- @@delCaption:
- CALL RemoveStr
-
- @@noCaption:
- ADD ESP, 16
-
- @@exit_draw:
- POP ESI
- POP EDI
- POP EBX
- MOV AL, 1
- RET
-
- @@noCN_DRAWITEM:
- CMP word ptr [EDX].TMsg.message, WM_LBUTTONDOWN
- JZ @@doDown
- CMP word ptr [EDX].TMsg.message, WM_KEYDOWN
- JNZ @@noWM_LBUTTONDOWN
- CMP [EDX].TMsg.wParam, 32
- JNZ @@noWM_LBUTTONDOWN
- @@doDown:
- PUSH EDX
- XCHG EBX, EAX
-
- CALL @@fixed_proc
- MOV ECX, [EBX].TControl.fRepeatInterval
- JECXZ @@exit_LBUTTONDOWN
- POP EDX
- PUSH EDX
- CMP word ptr [EDX].TMsg.message, WM_KEYDOWN
- JZ @@not_SetTimer
- PUSH 0
- PUSH [EBX].TControl.fRepeatInterval
- PUSH 1
- PUSH [EBX].TControl.fHandle
- CALL SetTimer
- @@exit_LBUTTONDOWN:
- @@not_SetTimer:
- POP EDX
- JMP @@invalidate
-
- @@noWM_LBUTTONDOWN:
- CMP word ptr [EDX].TMsg.message, WM_TIMER
- JNZ @@noWM_TIMER
-
- XCHG EBX, EAX
- PUSH 0
- PUSH 0
- PUSH BM_GETSTATE
- PUSH EBX
- CALL TControl.Perform
- {$IFDEF PARANOIA} DB $A8, 4 {$ELSE} TEST AL, BST_PUSHED {$ENDIF}
- JNZ @@pushed
- PUSH 1
- PUSH [EBX].TControl.fHandle
- CALL KillTimer
- CALL ReleaseCapture
- JMP @@noWM_TIMER
- @@fixed_proc:
- TEST byte ptr [EBX].TControl.fBitBtnOptions, 8 // bboFixed
- JZ @@not_fixed
- XOR [EBX].TControl.fChecked, 1
- MOV ECX, [EBX].TControl.fOnChange.TMethod.Code
- JECXZ @@not_fixed
- MOV EAX, [EBX].TControl.fOnChange.TMethod.Data
- MOV EDX, EBX
- JMP ECX
- @@pushed:
- CALL @@fixed_proc
- MOV EAX, EBX
- CALL TControl.DoClick
- @@invalidate:
- XCHG EAX, EBX
- CALL TControl.Invalidate
- @@noWM_TIMER:
- XOR EAX, EAX
- POP EBX
- @@not_fixed:
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcBitBtn( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var DIS: PDrawItemStruct;
- IsDown, IsDefault, IsDisabled: Boolean;
- Flags: Integer;
- X, Y, W, H, ImgW, ImgH, OutW, OutH, I, G, Bk, Blend: Integer;
- TxRect, FocusRect: TRect;
- OldFont: HFont;
- OldTextColor: TColor;
- CapText, CapTxtOrig: KOLString;
- TextSz: TSize;
- DC: HDC;
- OldBmp: HBitmap;
- Handled: Boolean;
- begin
- Result := False;
- if (Msg.message = WM_LBUTTONDBLCLK) then
- begin
- Rslt := Self_.Perform( WM_LBUTTONDOWN, Msg.wParam, Msg.lParam );
- Result := True;
- Exit;
- end;
- if (Msg.message = CN_DRAWITEM) then
- begin
- Result := True;
- Rslt := 1;
- DIS := Pointer( Msg.lParam );
- IsDown := (DIS.itemState and ODS_SELECTED <> 0) or Self_.fChecked;
- IsDefault := DIS.itemState and ODS_FOCUS <> 0;
- IsDisabled := DIS.itemState and ODS_DISABLED <> 0;
- G := 0;
- if IsDown then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 1 {$ELSE} 2 {$ENDIF};
- if IsDisabled then G := {$IFDEF BITBTN_DISABLEDGLYPH2} 2 {$ELSE} 1 {$ENDIF};
- if (G = 0) and IsDefault then G := 3;
- if ((G = 0) or (G = 3)) and Self_.MouseInControl then G := 4;
- if Assigned( Self_.fOnBitBtnDraw ) then
- begin
- if Assigned( Self_.fCanvas ) then
- Self_.fCanvas.SetHandle( DIS.hDC );
- Handled := Self_.fOnBitBtnDraw( Self_, G );
- if Assigned( Self_.fCanvas ) then
- Self_.fCanvas.SetHandle( 0 );
- if Handled then Exit;
- end;
- if not ( bboNoBorder in Self_.fBitBtnOptions ) then
- begin
- if IsDefault and not( bboFocusRect in Self_.fBitBtnOptions ) then
- begin
- {$ifdef wince}
- CeFrameRect( DIS.hDC, DIS.rcItem, clGray );
- {$else}
- Windows.FrameRect( DIS.hDC, DIS.rcItem, GetStockObject( {BLACK_BRUSH} DKGRAY_BRUSH ) );
- {$endif wince}
- InflateRect( DIS.rcItem, -1, -1 );
- end;
- if Self_.fFlat then
- begin
- if IsDown then
- Flags := BDR_RAISEDINNER
- else
- Flags := 0; //EDGE_ETCHED;
- DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_FLAT or BF_RECT );
- //InflateRect( DIS.rcItem, -1, -1 );
- end;
- if not Self_.fFlat or Self_.fMouseInControl or IsDefault then
- begin
- if IsDown then
- Flags := BDR_SUNKENOUTER or BDR_SUNKENINNER
- else
- Flags := BDR_RAISEDOUTER or BDR_RAISEDINNER;
- DrawEdge( DIS.hDC, DIS.rcItem, Flags, BF_ADJUST or BF_RECT );
- InflateRect( DIS.rcItem, -1, -1 );
- end;
- end;
- TxRect := DIS.rcItem;
- if Self_.fGlyphBitmap <> 0 then
- begin
- ImgW := Self_.fGlyphWidth;
- ImgH := Self_.fGlyphHeight;
- if (ImgW > 0) and (ImgH > 0) then
- begin
- OutW := ImgW;
- OutH := ImgH;
- W := DIS.rcItem.Right - DIS.rcItem.Left;
- H := DIS.rcItem.Bottom - DIS.rcItem.Top;
- X := DIS.rcItem.Left;
- Y := DIS.rcItem.Top;
- if isDown and (Self_.fGlyphLayout <> glyphOver) then
- begin
- Inc( X, Self_.TextShiftX );
- Inc( Y, Self_.TextShiftY );
- end;
- case Self_.fGlyphLayout of
- glyphLeft:
- begin
- Y := Y + (H - OutH) div 2;
- TxRect.Left := X + OutW;
- end;
- glyphTop:
- begin
- X := X + (W - OutW) div 2;
- TxRect.Top := Y + OutH;
- end;
- glyphRight:
- begin
- X := DIS.rcItem.Right - OutW;
- TxRect.Right := X;
- Y := Y + (H - OutH) div 2;
- end;
- glyphBottom:
- begin
- Y := DIS.rcItem.Bottom - OutH;
- TxRect.Bottom := Y;
- X := X + (W - OutW) div 2;
- end;
- glyphOver:
- begin
- X := X + (W - OutW) div 2;
- Y := Y + (H - OutH) div 2;
- end;
- end;
- if X < DIS.rcItem.Left then
- X := DIS.rcItem.Left;
- if Y < DIS.rcItem.Top then
- Y := DIS.rcItem.Top;
- if X + OutW > DIS.rcItem.Right then
- OutW := DIS.rcItem.Right - X;
- if Y + OutH > DIS.rcItem.Bottom then
- OutH := DIS.rcItem.Bottom - Y;
-
- if bboImageList in Self_.fBitBtnOptions then
- begin
- I := LoWord( Self_.fGlyphCount );
- if (HiWord( Self_.fGlyphCount ) > G) then
- I := I + G;
- Flags := 0; // ILD_NORMAL
- Blend := 0;
- if not Self_.fTransparent then
- Bk := Color2RGB( Self_.fColor )
- else
- begin
- Bk := Integer(CLR_NONE);
- Flags := ILD_TRANSPARENT;
- end;
- if HiWord( Self_.fGlyphCount ) = 1 then
- begin
- Blend := Integer(CLR_DEFAULT);
- if IsDefault then
- Flags := Flags or ILD_BLEND25;
- end;
- ImageList_DrawEx( Self_.fGlyphBitmap, I, DIS.hDC, X, Y, 0, 0,
- Bk, Blend, Flags );
- end
- else
- begin
- DC := CreateCompatibleDC( 0 );
- OldBmp := SelectObject( DC, Self_.fGlyphBitmap );
-
- I := 0;
- if Self_.fGlyphCount > G then
- I := I + G * ImgW;
- StretchBlt( DIS.hDC, X, Y, OutW, OutH, DC, I, 0, ImgW, ImgH, SRCCOPY );
-
- SelectObject( DC, OldBmp );
- DeleteDC( DC );
- end;
- end;
- end;
- if not (bboNoCaption in Self_.fBitBtnOptions) then
- if (TxRect.Right > TxRect.Left) and (TxRect.Bottom > TxRect.Top) then
- begin
- CapText := Self_.Caption;
- CapTxtOrig := CapText; /////////////////////////// added 19 Nov 2001
- if Assigned( Self_.FBitBtnGetCaption ) then
- CapText := Self_.FBitBtnGetCaption( Self_, CapText ); ////////////
- Bk := 0;
- Blend := 0;
- Flags := ETO_CLIPPED;
- if Self_.fTransparent or (Self_.fGlyphLayout = glyphOver) then
- Bk := SetBkMode( DIS.hDC, TRANSPARENT )
- else
- begin
- Flags := Flags or ETO_OPAQUE;
- Blend := SetBkColor( DIS.hDC, Color2RGB( Self_.fColor ) );
- end; // Returned previous BkMode is either OPAQUE=1 or TRANSPARENT=2
-
- OldFont := 0;
- if assigned( Self_.fFont ) then
- OldFont := SelectObject( DIS.hDC, Self_.fFont.Handle );
- OldTextColor := SetTextColor( DIS.hDC, Color2RGB( Self_.fTextColor ) );
-
- {Windows.}GetTextExtentPoint32( DIS.hDC, PKOLChar( CapText ), Length( CapText ),
- TextSz );
- W := TxRect.Right - TxRect.Left;
- H := TxRect.Bottom - TxRect.Top;
- Y := TxRect.Top + (H - TextSz.cy) div 2;
- case Self_.fTextAlign of
- taLeft: X := TxRect.Left;
- taCenter: X := TxRect.Left + (W - TextSz.cx) div 2;
- else {taRight:} X := TxRect.Right - TextSz.cx;
- end;
- if isDown then
- begin
- Inc( X, Self_.TextShiftX );
- Inc( Y, Self_.TextShiftY );
- end;
- if Y < 0 then
- Y := 0;
- if X < TxRect.Left then
- X := TxRect.Left;
-
- Windows.
- {$IFDEF UNICODE_CTRLS}
- ExtTextOutW
- {$ELSE}
- ExtTextOut
- {$ENDIF}
- ( DIS.hDC, X, Y, Flags, @TxRect,
- PKOLChar( CapText ), Length( CapText ), nil );
-
- if bboFocusRect in Self_.fBitBtnOptions then
- if IsDefault then
- begin
- FocusRect := TxRect;
- //InflateRect( FocusRect, 1, 1 );
- Windows.DrawFocusRect( DIS.hDC, FocusRect );
- end;
-
- if Assigned( Self_.FBitBtnExtDraw ) then // to provide underlying mnemonic characters
- Self_.FBitBtnExtDraw( Self_, DIS.hDC, X, Y, TxRect, CapText, CapTxtOrig,
- OldTextColor ); /////////////////////////////////
-
- SetTextColor( DIS.hDC, OldTextColor );
- if OldFont <> 0 then
- SelectObject( DIS.hDC, OldFont );
-
- if Blend = 0 then
- SetBkMode( DIS.hDC, Bk )
- else
- SetBkColor( DIS.hDC, Blend );
- end;
- end;
- if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN) and (Msg.wParam = 32) then
- begin
- if bboFixed in Self_.fBitBtnOptions then
- begin
- Self_.fChecked := not Self_.fChecked;
- if Assigned( Self_.fOnChange ) then
- Self_.fOnChange( Self_ );
- end;
- if Self_.fRepeatInterval > 0 then
- begin
- if Msg.message <> WM_KEYDOWN then
- SetTimer( Self_.fHandle, 1, 400, nil );
- Self_.Invalidate;
- end;
- end;
-
- if (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_KEYUP) then
- begin
- if Self_.fRepeatInterval > 0 then
- KillTimer( Self_.fHandle, 1 );
- end;
-
- if Msg.message = WM_KILLFOCUS then // to repaint when focus lost
- Self_.Invalidate;
-
- if Msg.message = WM_TIMER then
- begin
- KillTimer( Self_.fHandle, 1 );
- if bboFixed in Self_.fBitBtnOptions then
- begin
- Self_.fChecked := not Self_.fChecked;
- if Assigned( Self_.fOnChange ) then
- Self_.fOnChange( Self_ );
- end;
- Self_.DoClick;
- SetTimer( Self_.fHandle, 1, Self_.fRepeatInterval, nil );
- Self_.Invalidate;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcBitBtn]
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewBitBtn]
- function NewBitBtn( AParent: PControl; const Caption: String;
- Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
- GlyphCount: Integer ): PControl;
- begin
- new( Result, CreateBitBtn( AParent, Caption, Options, Layout, GlyphBitmap, GlyphCount ) );
- end;
- //[END NewBitBtn]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewBitBtn]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewBitBtn( AParent: PControl; const Caption: KOLString;
- Options: TBitBtnOptions; Layout: TGlyphLayout; GlyphBitmap: HBitmap;
- GlyphCount: Integer ): PControl;
- var
- B: TBitmapInfo;
- W, H: Integer;
- f: DWORD;
- begin
- f := WS_VISIBLE or WS_CHILD or BS_OWNERDRAW or WS_TABSTOP or BS_NOTIFY;
- Result := _NewControl( AParent, 'BUTTON', f, False, @ButtonActions );
- Result.fIgnoreDefault := TRUE;
- Result.fIsButton := TRUE;
- Result.fIsBitBtn := TRUE;
- Result.fCommandActions.aAutoSzX := 8;
- Result.fCommandActions.aAutoSzY := 8;
- Result.fBitBtnOptions := Options;
- Result.fGlyphLayout := Layout;
- Result.fGlyphBitmap := GlyphBitmap;
- with Result.fBoundsRect do
- begin
- Bottom := Top + 22;
- W := 0; H := 0;
- if GlyphBitmap <> 0 then
- begin
- if bboImageList in Options then
- ImageList_GetIconSize( GlyphBitmap, W, H )
- else
- begin
- if GetObject( GlyphBitmap, Sizeof(B), @B ) > 0 then
- begin
- W := B.bmiHeader.biWidth;
- H := B.bmiHeader.biHeight;
- if GlyphCount = 0 then
- GlyphCount := W div H;
- if GlyphCount > 1 then
- W := W div GlyphCount;
- end;
- end;
- if W > 0 then
- begin
- if (Caption = '') or (Layout = glyphOver) then
- begin
- Right := Left + W;
- Result.fCommandActions.aAutoSzX := 0;
- end
- else
- if Layout in [ glyphLeft, glyphRight ] then
- begin
- Right := Right + W;
- Inc( Result.fCommandActions.aAutoSzX, W );
- end;
- end;
- if H > 0 then
- begin
- if Layout in [ glyphTop, glyphBottom ] then
- begin
- Bottom := Bottom + H;
- Inc( Result.fCommandActions.aAutoSzY, H );
- end
- else
- begin
- Bottom := Top + H;
- Result.fCommandActions.aAutoSzY := 0;
- end;
- end;
- if not ( bboNoBorder in Options ) then
- begin
- if W > 0 then
- begin
- Inc( Right, 4 );
- if Result.fCommandActions.aAutoSzX > 0 then
- Inc( Result.fCommandActions.aAutoSzX, 4 );
- end;
- if H > 0 then
- begin
- Inc( Bottom, 4 );
- if Result.fCommandActions.aAutoSzY > 0 then
- Inc( Result.fCommandActions.aAutoSzY, 4 );
- end;
- end;
- end;
- Result.fGlyphWidth := W;
- Result.fGlyphHeight := H;
- end;
- Result.fGlyphCount := GlyphCount;
- if AParent <> nil then
- AParent.AttachProc( WndProc_DrawItem );
- Result.AttachProc( WndProcBitBtn );
- Result.fTextAlign := taCenter;
- Result.Caption := Caption;
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- Result.AttachProc( WndProcBtnReturnClick );
- {$ENDIF}
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_BitBtn(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewBitBtn]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Check box ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewCheckbox]
- function NewCheckbox( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateCheckbox( AParent, Caption ) );
- end;
- //[END NewCheckbox]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewCheckbox]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewCheckbox( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := NewButton( AParent, Caption );
- {$ifdef wince}
- Result.DetachProc(WndProcBtnFocus);
- {$endif wince}
- Result.fColor:=AParent.fColor;
- if Result.fBrush <> nil then
- Result.fBrush.fData.Color:=Result.fColor;
- with Result.fBoundsRect do
- begin
- Right := Left + 72;
- end;
- Result.fStyle := WS_VISIBLE or WS_CHILD or
- BS_AUTOCHECKBOX or WS_TABSTOP or BS_NOTIFY;
- Result.fCommandActions.aAutoSzX := 24;
- Result.fIgnoreDefault := FALSE;
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_CheckBox(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewCheckbox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //[function NewCheckBox3State]
- function NewCheckBox3State( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := NewCheckbox( AParent, Caption );
- Result.fStyle := Result.fStyle and not BS_AUTOCHECKBOX or BS_AUTO3STATE;
- end;
-
- //===================== Radiobox ========================//
-
- //[FUNCTION ClickRadio]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure ClickRadio( Sender:PObj );
- var Self_:PControl;
- begin
- Self_ := PControl( Sender );
- if Self_.FParent <> nil then
- CheckRadioButton( Self_.fParent.fHandle,
- Self_.fParent.fRadio1st,
- Self_.fParent.fRadioLast,
- Self_.fMenu );
- end;
- {$ENDIF ASM_VERSION}
- //[END ClickRadio]
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewRadiobox]
- function NewRadiobox( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateRadiobox( AParent, Caption ) );
- end;
- //[END NewRadiobox]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewRadiobox]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewRadiobox( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := NewCheckbox( AParent, Caption );
- Result.fStyle := WS_VISIBLE or WS_CHILD or
- BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP or BS_NOTIFY;
- {$ifdef wince}
- Result.DetachProc(WndProcBtnFocus);
- {$endif wince}
- Result.fControlClick := ClickRadio;
- if AParent <> nil then
- begin
- AParent.fRadioLast := Result.fMenu;
- if AParent.fRadio1st = 0 then
- begin
- AParent.fRadio1st := Result.fMenu;
- Result.SetRadioChecked;
- end;
- end;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_RadioBox(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewRadiobox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Label ========================//
-
- {$ENDIF WIN_GDI}
- {$IFNDEF USE_CONSTRUCTORS}
- {$IFDEF ASM_VERSION}
- const StaticClass: array[0..6]of Char=('S','T','A','T','I','C',#0);
- {$ENDIF ASM_VERSION}
- {$ENDIF not USE_CONSTRUCTORS}
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewLabel]
- function NewLabel( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateLabel( AParent, Caption ) );
- end;
- //[END NewLabel]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewLabel]
- {$IFDEF GDI}
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
- SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
- False ,@LabelActions );
- Inc( Result.fIsStaticControl );
- Result.fSizeRedraw := True;
- with Result.fBoundsRect do
- Bottom := Top + 22; //Right := Left + 64 {done in _NewControl};
- Result.Caption := Caption;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_Label(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure LabelSetTextAlign( Self_: PControl );
- begin
- gtk_misc_set_alignment( GTK_MISC( Self_.fCaptionHandle ), HorAlignments[ Self_.fTextAlign ],
- VerAlignments[ Self_.fVerticalAlign ] );
- end;
-
- function NewLabel( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or
- SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY,
- False, gtk_label_new( PChar( String( Caption ) ) ),
- TRUE );
- Result.fGetCaption := getLabelCaption;
- Result.fSetCaption := setLabelCaption;
- Inc( Result.fIsStaticControl );
- Result.fSetTextAlign := LabelSetTextAlign;
- Result.fTextAlign := taCenter;
- Result.TextAlign := taLeft;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$ENDIF USE_CONSTRUCTORS}
- //[END NewLabel]
-
- {$IFDEF WIN_GDI}
- //===================== word wrap Label ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewWordWrapLabel]
- function NewWordWrapLabel( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateWordWrapLabel( AParent, Caption ) );
- end;
- //[END NewWordWrapLabel]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewWordWrapLabel]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewWordWrapLabel( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := NewLabel( AParent, Caption );
- Result.fWordWrap := TRUE;
- with Result.fBoundsRect do
- begin
- Bottom := Top + 44;
- end;
- Result.fStyle := Result.fStyle and not SS_LEFTNOWORDWRAP;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewWordWrapLabel]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Label Effect ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- function NewLabelEffect( AParent: PControl; const Caption: String; ShadowDeep: Integer ): PControl;
- begin
- new( Result, CreateLabelEffect( AParent, Caption, ShadowDeep ) );
- end;
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewLabelEffect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewLabelEffect( AParent: PControl; const Caption: KOLString; ShadowDeep: Integer ): PControl;
- begin
- Result := NewLabel( AParent, '' );
- Dec( Result.fIsStaticControl ); // ñíîâà 0 !
- Result.AttachProc( WndProcLabelEffect );
- Result.Caption := Caption;
- Result.AttachProc( WndProcDoEraseBkgnd );
- Result.fTextAlign := taCenter;
- Result.fTextColor := clWindowText;
- Result.fShadowDeep := ShadowDeep;
- Result.fIgnoreWndCaption := True;
- with Result.fBoundsRect do
- begin
- Bottom := Top + 40;
- end;
- Result.fColor2 := clNone;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewLabelEffect]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Paint box ========================//
- {$ENDIF WIN_GDI}
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewPaintbox]
- function NewPaintbox( AParent: PControl ): PControl;
- begin
- new( Result, CreatePaintBox( AParent ) );
- end;
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewPaintbox]
- {$IFDEF GDI}
-
- {$UNDEF ASM_LOCAL}
- {$IFNDEF GRAPHCTL_XPSTYLES}
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_LOCAL}
- {$ENDIF ASM_VERSION}
- {$ENDIF GRAPHCTL_XPSTYLES}
-
- {$IFDEF ASM_LOCAL}
- function NewPaintbox( AParent: PControl ): PControl;
- asm
- XOR EDX, EDX
- CALL NewLabel
- ADD [EAX].TControl.fBoundsRect.Bottom, 64-22
- end;
- {$ELSE ASM_LOCAL} //Pascal
- function NewPaintbox( AParent: PControl ): PControl;
- begin
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD {or
- SS_LEFTNOWORDWRAP or SS_NOPREFIX }or SS_NOTIFY,
- False , @LabelActions );
- //Inc( Result.fIsStaticControl );
- Result.fSizeRedraw := True;
- //with Result.fBoundsRect do
- // Bottom := Top + 64; //Right := Left + 64 {done in _NewControl};
- Result.fClassicTransparent := Result.fTransparent;
- Result.fControlClassName := 'obj_PAINT';
- {$ELSE}
- Result := NewLabel( AParent, '' );
- with Result.fBoundsRect do
- begin
- Bottom := Top + 64; //Right := Left + 64 {done in NewLabel};
- end;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function NewPaintbox( AParent: PControl ): PControl;
- begin
- Result := NewLabel( AParent, '' );
- Result.Height := 64;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- //[END NewPaintbox]
-
- {$ENDIF USE_CONSTRUCTORS}
- {$IFDEF WIN_GDI}
-
- {$IFDEF _D2}
- //[API SetBrushOrgEx]
- function SetBrushOrgEx(DC: HDC; X, Y: Integer; PrevPt: PPoint): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external gdi32 name 'SetBrushOrgEx';
- {$ENDIF}
-
- //[FUNCTION WndProcDoEraseBkgnd]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION PAS_VERSION}
- function WndProcDoEraseBkgnd( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var DC: HDC;
- R: TRect;
- begin
- Result := FALSE;
- if Msg.message = WM_ERASEBKGND then
- begin
- Self_.CreateChildWindows;
- if Self_.Transparent then Exit;
- DC := Msg.wParam;
- SetBkMode( DC, OPAQUE );
- SetBkColor( DC, Color2RGB( Self_.fColor ) );
- SetBrushOrgEx( DC, 0, 0, nil );
- GetClientRect( Self_.fHandle, R );
- Windows.FillRect( DC, R, Global_GetCtlBrushHandle( Self_ ) );
- Rslt := 1;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcDoEraseBkgnd]
-
- //[function WndProcImageShow]
- function WndProcImageShow( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
- var PaintStruct: TPaintStruct;
- IL: PImageList;
- OldPaintDC: HDC;
- begin
- Result := FALSE;
- if (Msg.message = WM_PAINT) or (Msg.message = WM_PRINT) then
- begin
- OldPaintDC := Sender.fPaintDC;
- Sender.fPaintDC := Msg.wParam;
- if Sender.fPaintDC = 0 then
- Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
- IL := Sender.ImageListNormal;
- if IL <> nil then
- begin
- IL.Draw( Sender.fCurIndex, Sender.fPaintDC, Sender.fClientLeft, Sender.fClientTop );
- Result := TRUE;
- end;
- if Msg.wParam = 0 then
- EndPaint( Sender.fHandle, PaintStruct );
- Sender.fPaintDC := OldPaintDC;
- Rslt := 0;
- //Result := True;
- Exit;
- end;
- end;
-
- //[function NewImageShow]
- function NewImageShow( AParent: PControl; AImgList: PImageList;
- ImgIdx: Integer ): PControl;
- var W, H: Integer;
- begin
- Result := NewLabel( AParent, '' );
- Result.ImageListNormal := AImgList;
- Result.AttachProc( WndProcImageShow );
- Result.AttachProc( WndProcDoEraseBkgnd );
- W := 32; H := 32;
- if AImgList <> nil then
- begin
- W := AImgList.ImgWidth;
- H := AImgList.ImgHeight;
- end;
- with Result.fBoundsRect do
- begin
- Right := Left + W;
- Bottom := Top + H;
- end;
- end;
- //[END NewImageShow]
-
- //===================== Scrollbar ========================//
- const
- KSB_INITIALIZE = WM_USER + 10000;
- KSB_KEY = $3232;
-
- //[function WndProcScrollBarParent]
- function WndProcScrollBarParent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var
- Bar: PControl;
- SI: TScrollInfo;
- NewPos: Integer;
- AllowChange: Boolean;
- Cmd: Word;
-
- begin
- Result := False;
- case Msg.message of
- WM_HSCROLL, WM_VSCROLL:
- if (Msg.lParam <> 0) then begin
- {$IFDEF USE_PROP}
- Bar := Pointer(GetProp(Msg.lParam, ID_SELF));
- {$ELSE}
- Bar := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
- {$ENDIF}
- if (Bar <> nil) then begin
- FillChar(SI, SizeOf(SI), #0);
- SI.cbSize := SizeOf(SI);
- SI.fMask := SIF_RANGE or SIF_POS or SIF_TRACKPOS or SIF_PAGE;
- Bar.SBGetScrollInfo(SI);
-
- {Cmd := Msg.wParam and $0000FFFF;
- case Cmd of
- SB_BOTTOM: NewPos := SI.nMax;
- SB_TOP: NewPos := SI.nMin;
- SB_LINEDOWN: NewPos := SI.nPos + 1;
- SB_LINEUP: NewPos := SI.nPos - 1;
- SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
- SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
- SB_THUMBTRACK: NewPos := SI.nTrackPos;
- else
- Exit;
- end;}
- Cmd := Msg.wParam and $0000FFFF;
- case Cmd of
- SB_BOTTOM: NewPos := SI.nMax;
- SB_TOP: NewPos := SI.nMin;
- SB_LINEDOWN: NewPos := SI.nPos + 1;
- SB_LINEUP: NewPos := SI.nPos - 1;
- SB_PAGEDOWN: NewPos := SI.nPos + Integer(SI.nPage);
- SB_PAGEUP: NewPos := SI.nPos - Integer(SI.nPage);
- {!ecm}
- SB_THUMBPOSITION,SB_THUMBTRACK: NewPos := SI.nTrackPos;
- SB_ENDSCROLL: NewPos := SI.nPos;
- {/!ecm}
- else
- Exit;
- end;
-
- if (NewPos > SI.nMax - Integer(SI.nPage) + 1) then
- NewPos := SI.nMax - Integer(SI.nPage) + 1;
- if (NewPos < SI.nMin) then
- NewPos := SI.nMin;
-
- AllowChange := True;
- if Assigned(Bar.OnSBBeforeScroll) then
- Bar.OnSBBeforeScroll(Bar, SI.nPos, NewPos, Cmd, AllowChange);
- if AllowChange then
- SI.nPos := NewPos
- else
- SI.nTrackPos := SI.nPos;
- Bar.fSBPosition := SI.nPos;
- Bar.fSBPosition := Bar.SBSetScrollInfo(SI);
- if AllowChange and Assigned(Bar.OnSBScroll) then
- Bar.OnSBScroll(Bar, Cmd);
- end;
- end;
- end;
- end;
- //[END WndProcScrollBarParent]
-
- //[function NewScrollBar]
- function NewScrollBar( AParent: PControl; BarSide: TScrollerBar ): PControl;
- const SBS_Directions: array[ TScrollerBar ] of DWORD = ( SBS_HORZ {$ifndef wince} or SBS_BOTTOMALIGN{$endif wince},
- SBS_VERT {$ifndef wince}or SBS_RIGHTALIGN{$endif wince} );
- begin
- Result := _NewCommonControl(
- AParent,
- 'SCROLLBAR',
- WS_VISIBLE or WS_CHILD or SBS_Directions[ BarSide ],
- False,
- nil
- );
- {!ecm}
- Result.GetWindowHandle;
- {/!ecm}
- Result.DetachProc(WndProcCtrl);
- Result.fLookTabKeys := [tkTab];
-
- //#ecm Result.AttachProc(WndProcScrollBar);
- AParent.AttachProc(WndProcScrollBarParent);
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
- //[END NewScrollBar]
-
- //===================== Scrollbox ========================//
- //[function WndProcScrollBox]
- function WndProcScrollBox( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
-
- procedure DoScrollChildren;
- var
- OldNotifyProc: pointer;
- begin
- if Assigned( Sender.fScrollChildren ) then
- begin
- OldNotifyProc := @ Sender.fNotifyChild;
- Sender.fNotifyChild := nil;
- Sender.fScrollChildren( Sender );
- Sender.fNotifyChild := OldNotifyProc;
- end;
- end;
-
- var Bar: DWORD;
- SI: TScrollInfo;
- OldPos: integer;
- begin
- Result := FALSE;
- case Msg.message of
- WM_HSCROLL: Bar := SB_HORZ;
- WM_VSCROLL: Bar := SB_VERT;
- WM_SIZE: begin
- if Assigned( Sender.fNotifyChild ) then
- Sender.fNotifyChild( Sender, nil );
- Exit;
- end;
- WM_SHOWWINDOW:
- begin
- if WordBool(Msg.wParam) then begin
- Sender.fVisible:=False;
- Sender.CreateChildWindows;
- Sender.fVisible:=True;
- if Assigned(Sender.fNotifyChild) then
- Sender.fNotifyChild(Sender, nil);
- end;
- exit;
- end;
- else begin
- Exit;
- end;
- end;
-
- SI.cbSize := Sizeof( SI );
- SI.fMask := SIF_RANGE or SIF_POS or SIF_PAGE or
- {$IFDEF F_P}$10{$ELSE}SIF_TRACKPOS{$ENDIF};
- {$IFDEF _D2}
- GetScrollInfo( Sender.fHandle, Bar, SI );
- {$ELSE}
- GetScrollInfo( Sender.fHandle, Bar, SI );
- {$ENDIF}
- OldPos:=SI.nPos;
- SI.fMask := SIF_POS;
- case LoWord( Msg.wParam ) of
- SB_BOTTOM: SI.nPos := SI.nMax;
- SB_TOP: SI.nPos := SI.nMin;
- SB_LINEDOWN: Inc( SI.nPos, Sender.FScrollLineDist[ Bar ] );
- SB_LINEUP: Dec( SI.nPos, Sender.FScrollLineDist[ Bar ] );
- SB_PAGEDOWN: Inc( SI.nPos, Max( SI.nPage, 1 ) );
- SB_PAGEUP: Dec( SI.nPos, Max( SI.nPage, 1 ) );
- SB_THUMBTRACK:SI.nPos := SI.nTrackPos;
- end;
- if SI.nPos > SI.nMax - Integer( SI.nPage ) + 1 then
- SI.nPos := SI.nMax - Integer( SI.nPage ) + 1;
- if SI.nPos < SI.nMin then
- SI.nPos := SI.nMin;
- if OldPos = SI.nPos then exit;
- SetScrollInfo( Sender.fHandle, Bar, SI, TRUE );
- DoScrollChildren;
- end;
- //[END WndProcScrollBox]
-
- //[function NewScrollBox]
- function NewScrollBox( AParent: PControl; EdgeStyle: TEdgeStyle;
- Bars: TScrollerBars ): PControl;
- const Edgestyles: array[ TEdgeStyle ] of DWORD = ( {$ifdef wince}WS_BORDER, WS_BORDER{$else}WS_DLGFRAME, SS_SUNKEN{$endif}, 0, 0 );
- var SBFlag: Integer;
- begin
- SBFlag := EdgeStyles[ EdgeStyle ];
- if sbHorizontal in Bars then
- SBFlag := SBFlag or WS_HSCROLL;
- if sbVertical in Bars then
- SBFlag := SBFlag or WS_VSCROLL;
-
- Result := _NewControl( AParent, 'ScrollBox', WS_VISIBLE or WS_CHILD or
- SBFlag, EdgeStyle = esLowered, nil );
- Result.AttachProc( WndProcForm ); //!!!
- Result.AttachProc( WndProcScrollBox );
- Result.AttachProc( WndProcDoEraseBkgnd );
- Result.fIsControl := TRUE;
- end;
- //[END NewScrollBox]
-
- //[function WndProcNotifyParentAboutResize]
- function WndProcNotifyParentAboutResize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var P: PControl;
- begin
- if (Msg.message = WM_SIZE) or (Msg.message = WM_MOVE) or (Msg.message = CM_SHOW) then
- begin
- P := Sender.Parent;
- if P <> nil then
- if Assigned( P.fNotifyChild ) then
- P.fNotifyChild( P, nil );
- end
- else
- if (Msg.message = WM_SHOWWINDOW) and (Sender.Parent <> nil) and (Sender.Parent.Visible) then
- PostMessage( Sender.fHandle, CM_SHOW, 0, 0 );
- Result := FALSE;
- end;
-
- //[procedure CalcMinMaxChildren]
- procedure CalcMinMaxChildren( Self_: PControl; var SzR: TRect );
- var I: Integer;
- C: PControl;
- R: TRect;
- begin
- Szr := MakeRect( 0, 0, 0, 0 );
- for I := 0 to Self_.fChildren.fCount - 1 do
- begin
- C := Self_.fChildren.fItems[ I ];
- if C.ToBeVisible then
- begin
- R := C.BoundsRect;
- if (SzR.Left = SzR.Right) or (R.Left < SzR.Left) or (R.Right > SzR.Right) then
- begin
- if SzR.Left = SzR.Right then
- begin
- SzR.Left := R.Left;
- SzR.Right := R.Right;
- end
- else
- begin
- if R.Left < SzR.Left then SzR.Left := R.Left;
- if R.Right > SzR.Right then SzR.Right := R.Right;
- end;
- end;
- if (SzR.Top = SzR.Bottom) or (R.Top < SzR.Top) or (R.Bottom > SzR.Bottom) then
- begin
- if SzR.Top = SzR.Bottom then
- begin
- SzR.Top := R.Top;
- SzR.Bottom := R.Bottom;
- end
- else
- begin
- if R.Top < SzR.Top then SzR.Top := R.Top;
- if R.Bottom > SzR.Bottom then SzR.Bottom := R.Bottom;
- end;
- end;
- end;
- end;
- Dec( SzR.Left, Self_.Border );
- Inc( SzR.Right, Self_.Border - 1 );
- Dec( SzR.Top, Self_.Border );
- Inc( SzR.Bottom, Self_.Border - 1 );
- end;
-
- //[procedure NotifyScrollBox]
- procedure NotifyScrollBox( Self_, Child: PControl );
- var SI: TScrollInfo;
-
- procedure GetSetScrollInfo( SBar: DWORD; WH, R_RightBottom, SzR_LeftTop, SzR_RightBottom: Integer );
- {$IFDEF SBOX_OLDPOS} var OldPos: Double; {$ENDIF}
- begin
- {$IFDEF SBOX_OLDPOS} OldPos := 0; {$ENDIF}
- if not GetScrollInfo( Self_.fHandle, SBar, SI ) then
- begin
- SI.nMin := 0;
- SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
- end
- else
- begin
- {$IFDEF SBOX_OLDPOS}
- if SI.nMax > SI.nMin then
- begin
- OldPos := (SI.nPos - SI.nMin) / (SI.nMax - SI.nMin);
- SI.nMin := 0;
- SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
- if SzR_LeftTop < 0 then
- SI.nMax := Max( R_RightBottom - SzR_LeftTop - 1, WH - 1 );
- end
- else
- begin
- SI.nMin := 0;
- SI.nMax := Max( R_RightBottom - 1, SzR_RightBottom - 1 );
- end;
- {$ENDIF}
- SI.nMin := 0; {!ecm}
- SI.nMax := SzR_RightBottom - SzR_LeftTop; {!ecm}
- end;
- {$IFDEF SBOX_OLDPOS}
- SI.nPos := SI.nMin + Round( (SI.nMax - SI.nMin) * OldPos );
- {$ELSE}
- SI.nPos := - SzR_LeftTop;
- {$ENDIF}
- SI.nPage := R_RightBottom;
- SetScrollInfo( Self_.fHandle, SBar, SI, TRUE );
- end;
-
- var W, H: Integer;
- SzR: TRect;
- R: TRect;
- begin
- if Assigned( Child ) then
- begin
- Child.AttachProc( WndProcNotifyParentAboutResize );
- Exit;
- end;
- CalcMinMaxChildren( Self_, SzR );
- W := SzR.Right - SzR.Left;
- H := SzR.Bottom - SzR.Top;
-
- R := Self_.ClientRect;
- if (R.Right = 0) or (R.Bottom = 0) then Exit; // for case when form is minimized
- SI.cbSize := sizeof( SI );
- SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
-
- SI.cbSize := sizeof( SI );
- SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS;
-
- GetSetScrollInfo( SB_HORZ, W, R.Right, SzR.Left, SzR.Right );
- {+ecm}R := Self_.ClientRect;{/+ecm}
- GetSetScrollInfo( SB_VERT, H, R.Bottom, SzR.Top, SzR.Bottom );
- {+ecm} if Assigned( Self_.fScrollChildren ) then Self_.fScrollChildren(Self_); {/+ecm}
- end;
-
- //[procedure ScrollChildren]
- procedure ScrollChildren( _Self_: PControl );
- var SzR, R: TRect;
- I, Xpos, Ypos: Integer;
- OldNotifyProc: Pointer;
- C: PControl;
- DeltaX, DeltaY: Integer;
-
- begin
- if not _Self_.Visible then exit;
- CalcMinMaxChildren( _Self_, SzR );
- Xpos := GetScrollPos( _Self_.fHandle, SB_HORZ );
- Ypos := GetScrollPos( _Self_.fHandle, SB_VERT );
-
- DeltaX := -Xpos - SzR.Left;
- DeltaY := -Ypos - SzR.Top;
-
- if (DeltaX <> 0) or (DeltaY <> 0) then
- begin
-
- OldNotifyProc := @ _Self_.fNotifyChild;
- _Self_.fNotifyChild := nil;
-
- for I := 0 to _Self_.fChildren.fCount - 1 do
- begin
- C := _Self_.fChildren.fItems[ I ];
- R := C.BoundsRect;
- OffsetRect( R, DeltaX, DeltaY );
- C.BoundsRect := R;
- {$ifndef wince}
- C.Invalidate;
- {$endif wince}
- end;
- _Self_.Update;
- _Self_.fNotifyChild := OldNotifyProc;
- (*
- CalcMinMaxChildren( _Self_, R );
- if //(SzR.Left <> R.Left) or (SzR.Top <> R.Top) or
- //(Szr.Right <> R.Right) or (SzR.Bottom <> R.Bottom)
- ((SzR.Right - SzR.Left) <> (R.Right - R.Left)) or
- ((SzR.Bottom - SzR.Top) <> (R.Bottom - R.Top))
- then
- if Assigned( _Self_.fNotifyChild ) then
- _Self_.fNotifyChild( _Self_, nil );
- *)
- end;
-
- end;
-
- //[function NewScrollBoxEx]
- function NewScrollBoxEx( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
- begin
- Result := NewScrollBox( AParent, EdgeStyle, [ ] );
- Result.fNotifyChild := NotifyScrollBox;
- Result.fScrollChildren := ScrollChildren;
- Result.FScrollLineDist[ 0 ] := 16;
- Result.FScrollLineDist[ 1 ] := 16;
- end;
-
- //[function WndProcOnScroll]
- function WndProcOnScroll( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Bar: TScrollerBar;
- begin
- Bar := sbHorizontal; //0
- if Msg.message = WM_VSCROLL then
- Bar := sbVertical
- else
- if Msg.message <> WM_HSCROLL then
- begin
- Result := FALSE;
- Exit;
- end;
-
- if Assigned( Sender.OnScroll ) then
- Sender.OnScroll( Sender, Bar, LoWord( Msg.wParam ), HiWord( Msg.wParam ) );
- Result := FALSE;
- end;
-
- //[procedure TControl.SetOnScroll]
- procedure TControl.SetOnScroll(const Value: TOnScroll);
- begin
- FOnScroll := Value;
- AttachProc( @ WndProcOnScroll );
- end;
-
- //===================== Groupbox ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewGroupbox]
- function NewGroupbox( AParent: PControl; const Caption: String ): PControl;
- begin
- new( Result, CreateGroupbox( AParent, Caption ) );
- end;
- //[END NewGroupbox]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewGroupbox]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewGroupbox( AParent: PControl; const Caption: KOLString ): PControl;
- begin
- Result := _NewControl( AParent, 'BUTTON',
- WS_CHILD
- or WS_CLIPSIBLINGS
- or WS_CLIPCHILDREN
- or WS_VISIBLE
- or BS_GROUPBOX,
- FALSE, @ButtonActions );
- {$ifndef wince}
- Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
- {$endif wince}
- Result.Caption := Caption;
- with Result.fBoundsRect do
- begin
- Right := Left + 100;
- Bottom := Top + 100;
- end;
- Result.fClientTop := {$ifdef wince}8{$else}22{$endif};
- Result.fClientBottom := 2;
- Result.fClientLeft := 2;
- Result.fClientRight := 2;
- Result.fTabstop := False;
- Result.fIsGroupBox := TRUE;
- Result.AttachProc( WndProcDoEraseBkgnd );
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- //if AppTheming then
- // Result.Style := Result.Style or BS_OWNERDRAW;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_GroupBox(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewGroupbox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Panel ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewPanel]
- function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
- begin
- new( Result, CreatePanel( AParent, EdgeStyle ) );
- end;
- //[END NewPanel]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewPanel]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewPanel( AParent: PControl; EdgeStyle: TEdgeStyle ): PControl;
- {$ifdef win32}
- const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0, 0 );
- {$endif win32}
- begin
- Result := _NewControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or SS_NOTIFY or
- SS_LEFTNOWORDWRAP or SS_NOPREFIX, False, @LabelActions );
- with Result.fBoundsRect do
- begin
- Right := Left + 100;
- Bottom := Top + 100;
- end;
- {$ifdef wince}
- if EdgeStyle in [esRaised, esLowered] then
- Result.fStyle := Result.fStyle or WS_BORDER;
- {$else}
- Result.fStyle := Result.fStyle or Edgestyles[ EdgeStyle ];
- Result.fExStyle := Result.fExStyle or WS_EX_CONTROLPARENT;
- {$endif wince}
- Result.fVerticalAlign := vaTop;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- if AppTheming then
- Result.fStyle := Result.fStyle and (not Edgestyles[ EdgeStyle ]);
- Result.SetEdgeStyle(EdgeStyle);
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_Panel(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewPanel]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Splitter ==============================//
-
- //{$DEFINE USE_ASM_DODRAG}
-
- {$IFNDEF USE_ASM_DODRAG}
- {$DEFINE USE_PAS_DODRAG}
- {$ENDIF}
- {$IFNDEF ASM_VERSION}
- {$DEFINE USE_PAS_DODRAG}
- {$ENDIF}
- {$IFDEF USE_PAS_DODRAG}
- //[procedure DoDrag]
- procedure DoDrag( Self_: PControl; Cancel: Boolean{$ifdef wince}; MousePos: TPoint{$endif});
- var NewSize1, NewSize2: Integer;
- {$ifndef wince}
- MousePos: TPoint;
- {$endif wince}
- R: TRect;
- Prev: PControl;
- I, M : Integer;
- begin
- if Self_.fDragging then
- begin
- I := Self_.fParent.fChildren.IndexOf( Self_ );
- Prev := Self_;
- if I > 0 then
- Prev := Self_.FParent.fChildren.fItems[ I - 1 ];
- {$ifndef wince}
- if Cancel then
- MousePos := Self_.fSplitStartPos
- else
- GetCursorPos( MousePos );
- {$endif wince}
- M := 1;
- if Self_.FAlign in [ caRight, caBottom ] then
- M := -1;
- if Self_.FAlign in [ caTop, caBottom ] then
- begin
- NewSize1 := (MousePos.y - Self_.fSplitStartPos.y)* M
- + Self_.fSplitStartSize;
- NewSize2 := Self_.fParent.ClientHeight - NewSize1
- - Self_.fBoundsRect.Bottom + Self_.fBoundsRect.Top
- - Self_.fParent.fMargin * 4;
- if Self_.fSecondControl <> nil then
- begin
- NewSize2 := Self_.fSecondControl.fBoundsRect.Bottom
- - Self_.fSecondControl.fBoundsRect.Top;
- if Self_.fSecondControl.FAlign = caClient then
- NewSize2 := Self_.fSplitStartPos2.y
- - (MousePos.y - Self_.fSplitStartPos.y)* M
- - Self_.fParent.fMargin * 4;
- end;
- end
- else
- begin
- NewSize1 := (MousePos.x - Self_.fSplitStartPos.x)* M
- + Self_.fSplitStartSize;
- NewSize2 := Self_.fParent.ClientWidth - NewSize1
- - Self_.fBoundsRect.Right + Self_.fBoundsRect.Left
- - Self_.fParent.fMargin * 4;
- if Self_.fSecondControl <> nil then
- begin
- NewSize2 := Self_.fSecondControl.fBoundsRect.Right
- - Self_.fSecondControl.fBoundsRect.Left;
- if Self_.fSecondControl.FAlign = caClient then
- NewSize2 := Self_.fSplitStartPos2.x
- - (MousePos.x - Self_.fSplitStartPos.x)* M
- - Self_.fParent.Margin * 4;
- end;
- end;
- if (NewSize1 < Self_.fSplitMinSize1) then
- begin
- Dec( NewSize2, Self_.fSplitMinSize1 - NewSize1 );
- NewSize1 := Self_.fSplitMinSize1;
- end;
- if (NewSize2 < Self_.fSplitMinSize2) then
- begin
- Dec( NewSize1, Self_.fSplitMinSize2 - NewSize2 );
- NewSize2 := Self_.fSplitMinSize2;
- end;
- if NewSize1 < Self_.fSplitMinSize1 then Exit;
- if NewSize2 < Self_.fSplitMinSize2 then Exit;
- if assigned( Self_.fOnSplit ) then
- if not Self_.fOnSplit( Self_, NewSize1, NewSize2 ) then Exit;
- R := Prev.BoundsRect;
- case Self_.FAlign of
- caTop: R.Bottom := R.Top + NewSize1;
- caBottom: R.Top := R.Bottom - NewSize1;
- caRight: R.Left := R.Right - NewSize1;
- else R.Right := R.Left + NewSize1;
- end;
- Prev.BoundsRect := R;
- {$IFDEF OLD_ALIGN}
- Global_Align( Self_.fParent );
- {$ELSE NEW_ALIGN}
- Global_Align( Self_ );
- {$ENDIF}
- end;
- end;
- {$ENDIF}
-
- const
- chkLeft=2;
- chkTop=4;
- chkRight=8;
- chkBott=16;
-
- {$DEFINE USE!_ASM_DODRAG}
-
- //[FUNCTION WndProcSplitter]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcSplitter( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- Prev: PControl;
-
- procedure FinDrag;
- begin
- KillTimer( Self_.fHandle, $7B );
- Self_.fDragging := False;
- ReleaseCapture;
- end;
- {$ifdef wince}
- function GetMouseCursorPos(lParam: DWORD): TPoint;
- begin
- Result:=Self_.Client2Screen(MakePoint(SmallInt(LOWORD(Msg.lParam)), SmallInt(HIWORD(Msg.lParam))));
- end;
- {$endif wince}
- begin
- case Msg.message of
- {$ifndef wince}
- WM_NCHITTEST:
- begin
- Rslt := DefWindowProc( Self_.fHandle, Msg.message, Msg.wParam, Msg.lParam );
- if Rslt > 0 then
- Rslt := HTCLIENT;
- Result := True;
- Exit;
- end;
- {$endif wince}
- WM_MOUSEMOVE:
- begin
- Windows.SetCursor( Self_.fCursor );
- DoDrag( Self_, False {$ifdef wince},GetMouseCursorPos(Msg.lParam){$endif} );
- end;
- WM_LBUTTONDOWN:
- begin
- if Self_.fParent <> nil then
- begin
- I := Self_.fParent.fChildren.IndexOf( Self_ );
- Prev := Self_;
- if I > 0 then
- Prev := Self_.FParent.fChildren.fItems[ I - 1 ];
- if Self_.fAlign in [ caTop, caBottom ] then
- Self_.fSplitStartSize := Prev.Height
- else
- Self_.fSplitStartSize := Prev.Width;
- if Self_.fSecondControl <> nil then
- Self_.fSplitStartPos2 :=
- MakePoint( Self_.fSecondControl.Width, Self_.fSecondControl.Height );
- SetCapture( Self_.fHandle );
- Self_.fDragging := True;
- SetTimer( Self_.fHandle, $7B, 100, nil );
- {$ifdef wince}
- Self_.fSplitStartPos:=GetMouseCursorPos(Msg.lParam);
- {$else}
- GetCursorPos( Self_.fSplitStartPos );
- {$endif wince}
- end;
- end;
- WM_LBUTTONUP:
- begin
- DoDrag( Self_, False {$ifdef wince},GetMouseCursorPos(Msg.lParam){$endif});
- FinDrag;
- end;
- WM_TIMER:
- if Self_.fDragging and (GetAsyncKeyState( VK_ESCAPE ) < 0) then
- begin
- DoDrag( Self_, True {$ifdef wince},Self_.fSplitStartPos{$endif});
- FinDrag;
- end;
- end;
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcSplitter]
-
- //[function NewSplitter]
- function NewSplitter( AParent: PControl; MinSizePrev, MinSizeNext: Integer ): PControl;
- begin
- Result := NewSplitterEx( AParent, MinSizePrev, MinSizeNext, esLowered );
- end;
- //[END NewSplitter]
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewSplitterEx]
- function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
- EdgeStyle: TEdgeStyle ): PControl;
- begin
- new( Result, CreateSplitter( AParent, MinSizePrev, MinSizeNext, EdgeStyle ) );
- end;
- //[END NewSplitterEx]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewSplitterEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewSplitterEx( AParent: PControl; MinSizePrev, MinSizeNext: Integer;
- EdgeStyle: TEdgeStyle ): PControl;
- var PrevCtrl: PControl;
- Sz0: Integer;
- begin
- Result := NewPanel( AParent, EdgeStyle );
- Result.fSplitMinSize1 := MinSizePrev;
- Result.fSplitMinSize2 := MinSizeNext;
- Result.fIsSplitter := TRUE;
- Sz0 := 4;
- with Result.fBoundsRect do
- begin
- Right := Left + Sz0;
- Bottom := Top + Sz0;
- end;
- if AParent <> nil then
- begin
- if AParent.fChildren.fCount > 1 then
- begin
- PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ];
- case PrevCtrl.FAlign of
- caLeft, caRight:
- begin
- Result.fCursor := LoadCursor( 0, IDC_SIZEWE );
- end;
- caTop, caBottom:
- begin
- Result.fCursor := LoadCursor( 0, IDC_SIZENS );
- end;
- end;
- Result.Align := PrevCtrl.FAlign;
- end;
- end;
- Result.AttachProc( WndProcSplitter );
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_Splitter(Result);
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewSplitterEx]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== MDI client window control =============//
- {$ifdef win32}
- //[procedure DestroyMDIChildren]
- procedure DestroyMDIChildren( Form: PControl );
- var MDIClient: PControl;
- I: Integer;
- Ch: PControl;
- begin
- MDIClient := Form.fMDIClient;
- MDIClient.fMDIDestroying := TRUE;
- if MDIClient = nil then Exit;
- if MDIClient.fMDIChildren <> nil then
- for I := MDIClient.fMDIChildren.Count - 1 downto 0 do
- begin
- Ch := MDIClient.fMDIChildren.fItems[ I ];
- if Ch.fHandle <> 0 then
- MDIClient.Perform( WM_MDIDESTROY, Ch.fHandle, 0 );
- end;
- MDIClient.fMDIChildren.Free;
- MDIClient.fMDIChildren := nil;
- if Form.fMenu <> 0 then
- begin
- MDIClient.Perform( WM_MDISETMENU, 0, 0 );
- MDIClient.Perform( WM_MDIREFRESHMENU, 0, 0 );
- DrawMenuBar( Form.fHandle );
- Form.fMenuObj.Free;
- Form.fMenuObj := nil;
- end;
- Form.fMDIClient := nil;
- MDIClient.Free;
- end;
-
- //[function ProcMDIAccel]
- function ProcMDIAccel( Applet: PControl; var Msg: TMsg ): Boolean;
- var Form: PControl;
- begin
- Result := FALSE;
- if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
- begin
- Form := Applet.ActiveControl;
- if Form <> nil then
- begin
- if Form.IsMDIChild then
- Form := Form.Parent;
- Form := Form.ParentForm;
- if (Form <> nil) and (Form.MDIClient <> nil) then
- Result := TranslateMDISysAccel( Form.MDIClient.fHandle, Msg );
- end;
- end;
- end;
-
- //[function CallDefFrameProc]
- function CallDefFrameProc( Wnd: HWnd; Msg: Integer; wParam, lParam: Integer ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var Form: PControl;
- begin
- {$IFDEF USE_PROP}
- Form := Pointer( GetProp( Wnd, ID_SELF ) );
- {$ELSE}
- Form := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
- {$ENDIF}
- if Form <> nil then
- Form := Form.ParentForm;
- if (Form <> nil) and (Form.fMDIClient <> nil) then
- Result := DefFrameProc( Wnd, Form.fMDIClient.fHandle, Msg, wParam, lParam )
- else
- Result := DefWindowProc( Wnd, Msg, wParam, lParam );
- end;
-
- //[function WndFuncMDIClient]
- function WndFuncMDIClient( Wnd: HWnd; Msg, wParam, lParam: Integer ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var C: PControl;
- M: TMsg;
- begin
- {$IFDEF USE_PROP}
- C := Pointer( GetProp( Wnd, ID_SELF ) );
- {$ELSE}
- C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
- {$ENDIF}
- if C <> nil then
- begin
- M.hwnd := Wnd;
- M.message := Msg;
- M.wParam := wParam;
- M.lParam := lParam;
- Result := C.WndProc( M );
- end
- else
- Result := DefWindowProc( Wnd, Msg, wParam, lParam );
- end;
-
- //[function ShowMDIClientEdge]
- function ShowMDIClientEdge( MDIClient: PControl ): Boolean;
- var ShowEdge: Boolean;
- I: Integer;
- Ch: PControl;
- ExStyle: Integer;
- begin
- Result := FALSE;
- ShowEdge := TRUE;
- if MDIClient.fMDIChildren.Count > 0 then
- for I := 0 to MDIClient.fMDIChildren.Count-1 do
- begin
- Ch := MDIClient.fMDIChildren.fItems[ I ];
- if IsZoomed( Ch.fHandle ) then
- begin
- ShowEdge := FALSE;
- break;
- end;
- end;
- ExStyle := MDIClient.ExStyle;
- if ShowEdge then
- if ExStyle and WS_EX_CLIENTEDGE = 0 then
- ExStyle := ExStyle or WS_EX_CLIENTEDGE
- else
- Exit
- else if ExStyle and WS_EX_CLIENTEDGE <> 0 then
- ExStyle := ExStyle and not WS_EX_CLIENTEDGE
- else
- Exit;
- MDIClient.ExStyle := ExStyle;
- Result := TRUE;
- end;
-
- //[function WndProcMDIClient]
- function WndProcMDIClient( MDIClient: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if not MDIClient.fMDIDestroying then
- case Msg.message of
- $3f:
- begin
- PostMessage( MDIClient.fHandle, CM_MDIClientShowEdge, 0, 0 );
- end;
- CM_MDIClientShowEdge:
- begin
- ShowMDIClientEdge( MDIClient );
- end;
- WM_NCHITTEST: // not necessary though
- begin
- Rslt := DefWindowProc( MDIClient.fHandle, WM_NCHITTEST, Msg.wParam, Msg.lParam );
- if Rslt = HTCLIENT then Rslt := HTTRANSPARENT;
- end;
- WM_WINDOWPOSCHANGING:
- begin
- MDIClient.Perform( WM_SETREDRAW, 0, 0 );
- end;
- WM_WINDOWPOSCHANGED:
- begin
- Global_Align( {$IFDEF OLD_ALIGN}MDIClient.Parent{$ELSE}MDIClient{$ENDIF} );
- MDIClient.Invalidate;
- MDIClient.Parent.Invalidate;
- MDIClient.Perform( WM_SETREDRAW, 1, 0 );
- PostMessage( MDIClient.fHandle, CM_INVALIDATE, 0, 0 );
- end;
- CM_INVALIDATE:
- begin
- MDIClient.InvalidateNC( TRUE );
- MDIClient.InvalidateEx;
- end;
- end;
- Result := FALSE;
- end;
-
- // function added by Thaddy de Koning to fix MDI behaviour
- //[function WndProcParentNotifyMouseLDown]
- function WndProcParentNotifyMouseLDown( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if (Sender.IsMDIChild) and (Msg.message = WM_PARENTNOTIFY) and
- (LOWORD(msg.wparam)=WM_LBUTTONDOWN) then
- BringWindowToTop( Sender.Handle );
- end;
-
- //[function NewMDIClient]
- function NewMDIClient( AParent: PControl; WindowMenu: THandle ): PControl;
- var F: PControl;
- CCS: TClientCreateStruct;
- PrntWin: HWnd;
- begin
- F := nil;
- PrntWin := 0;
- if AParent <> nil then
- begin
- F := AParent.ParentForm;
- if F <> nil then
- begin
- F.Add2AutoFreeEx( TObjectMethod( MakeMethod( F, @ DestroyMDIChildren ) ) );
- F.GetWindowHandle; // must be created before MDI client creation
- F.fDefWndProc := @CallDefFrameProc;
- end;
- PrntWin := AParent.GetWindowHandle;
- end;
- Applet.fExMsgProc := ProcMDIAccel;
- Result := _NewControl( AParent, 'MDICLIENT',
- WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
- WS_VISIBLE or WS_TABSTOP or MDIS_ALLCHILDSTYLES, TRUE, nil );
- Result.fMDIChildren := NewList;
- Result.fExStyle := WS_EX_CLIENTEDGE;
-
- CCS.hWindowMenu := WindowMenu;
- CCS.idFirstChild := $FF00;
- Result.fHandle := CreateWindowEx( WS_EX_CLIENTEDGE, 'MDICLIENT', nil,
- WS_CHILD or WS_CLIPCHILDREN or WS_VSCROLL or WS_HSCROLL or
- WS_VISIBLE or WS_TABSTOP,
- 0, 0, 0, 0, PrntWin, 0, hInstance, @ CCS );
- Result.fDefWndProc := Pointer( GetWindowLong( Result.fHandle, GWL_WNDPROC ) );
- SetWindowLong( Result.fHandle, GWL_WNDPROC, Integer( @WndFuncMDIClient ) );
- {$IFDEF USE_PROP}
- SetProp( Result.fHandle, ID_SELF, Integer( Result ) );
- {$ELSE}
- SetWindowLong( Result.fHandle, GWL_USERDATA, Integer( Result ) );
- {$ENDIF}
- if F <> nil then
- F.fMDIClient := Result;
- Result.AttachProc( WndProcMDIClient );
- Result.GetWindowHandle;
-
- Applet.AttachProc( WndProcParentNotifyMouseLDown );
- end;
-
- //===================== MDI child window object ==============//
- //[function MDIChildFunc]
- function MDIChildFunc( Wnd: HWnd; Msg: DWord; wParam, lParam: Integer ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var C: PControl;
- M: TMsg;
- begin
- {$IFDEF USE_PROP}
- C := Pointer( GetProp( Wnd, ID_SELF ) );
- {$ELSE}
- C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
- {$ENDIF}
- if C <> nil then
- begin
- M.hwnd := Wnd;
- M.message := Msg;
- M.wParam := wParam;
- M.lParam := lParam;
- Result := C.WndProc( M );
- end
- else
- Result := DefMDIChildProc( Wnd, Msg, wParam, lParam );
- end;
-
- //[function Pass2DefMDIChildProc]
- function Pass2DefMDIChildProc( Sender_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if Sender_ = nil then Exit;
- if Sender_.Parent = nil then Exit;
- if Sender_.Parent.fDestroying then Exit;
- if (Msg.message = WM_SYSCOMMAND) or (Msg.message = WM_CHILDACTIVATE) or
- (Msg.message = WM_SETFOCUS) or (Msg.message = WM_SIZE) or
- (Msg.message = WM_MOVE) or (Msg.message = WM_MENUCHAR) or
- (Msg.message = WM_GETMINMAXINFO) {and IsZoomed( Sender_.fHandle ) and (Msg.hwnd = Sender_.fHandle) -- doesn't work -- } then
- begin
- Rslt := DefMDIChildProc( Msg.hwnd, Msg.message, Msg.lParam, Msg.wParam );
- Result := TRUE;
- end;
- end;
-
- //[function WndProcMDIChild]
- function WndProcMDIChild( MDIChild: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var ClientWnd: HWnd;
- MDIClient: PControl;
- MDIForm: PControl;
- begin
- Result := FALSE;
- MDIClient := MDIChild.Parent;
- if MDIClient = nil then Exit;
- ClientWnd := MDIClient.fHandle;
- if ClientWnd = 0 then Exit;
- case Msg.message of
- WM_DESTROY:
- begin
- MDIClient.fMDIChildren.Remove( MDIChild );
- MDIForm := MDIClient.ParentForm;
- if MDIForm <> nil then
- if MDIForm.fHandle <> 0 then
- DrawMenuBar( MDIForm.fHandle );
- MDIChild.Free;
- Result := TRUE;
- Exit;
- end;
- end;
- if MDIChild.fNotAvailable then
- begin
- MDIChild.fNotAvailable := FALSE;
- MDIChild.Invalidate;
- end;
- end;
-
- //[procedure CreateMDIChildExt]
- procedure CreateMDIChildExt( Sender: PControl );
- var F: PControl;
- begin
- F := Sender.Parent;
- if F <> nil then
- F := F.ParentForm;
- if F <> nil then
- DrawMenuBar( F.fHandle );
- end;
-
- //[function NewMDIChild]
- function NewMDIChild( AParent: PControl; const ACaption: String ): PControl;
- var MDIClient: PControl;
- begin
- Assert( (AParent <> nil) and (AParent.ParentForm <> nil) and
- (AParent.ParentForm.fMDIClient <> nil), 'Error creating MDI child' );
- MDIClient := AParent.ParentForm.fMDIClient;
- Result := NewForm( MDIClient, ACaption );
- Result.fIsMDIChild := TRUE;
- Result.fMenu := CtlIdCount;
- Inc( CtlIdCount );
- MDIClient.fMDIChildren.Add( Result );
- Result.fExStyle := Result.fExStyle or WS_EX_MDICHILD;
- Result.fWndFunc := @ MDIChildFunc;
- Result.fDefWndProc := @DefMDIChildProc;
- Result.fPass2DefProc := Pass2DefMDIChildProc;
- Result.AttachProc( WndProcMDIChild );
-
- Result.SubClassName := 'MDI_chld';
- Result.fNotAvailable := TRUE;
- Result.fCreateWndExt := CreateMDIChildExt;
-
- end;
- {$endif win32}
-
- //===================== Gradient panel ========================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewGradientPanel]
- function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
- begin
- new( Result, CreateGradientPanel( AParent, Color1, Color2 ) );
- end;
- //[END NewGradientPanel]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewGradientPanel]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewGradientPanel( AParent: PControl; Color1, Color2: TColor ): PControl;
- begin
- Result := NewLabel( AParent, '' );
- Result.AttachProc( WndProcGradient );
- Result.fColor2 := Color2;
- Result.fColor1 := Color1;
- with Result.fBoundsRect do
- begin
- Right := Left + 40;
- Bottom := Top + 40;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewGradientPanel]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewGradientPanelEx]
- function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
- Style: TGradientStyle; Layout: TGradientLayout ): PControl;
- begin
- new( Result, CreateGradientPanelEx( AParent, Color1, Color2,
- Style, Layout ) );
- end;
- //[END NewGradientPanelEx]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewGradientPanelEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewGradientPanelEx( AParent: PControl; Color1, Color2: TColor;
- Style: TGradientStyle; Layout: TGradientLayout ): PControl;
- begin
- Result := NewLabel( AParent, '' );
- Result.AttachProc( WndProcGradientEx );
- Result.fColor2 := Color2;
- Result.fColor1 := Color1;
- Result.fGradientStyle := Style;
- Result.fGradientLayout := Layout;
- with Result.fBoundsRect do
- begin
- Right := Left + 40;
- Bottom := Top + 40;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewGradientPanelEx]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Edit box ========================//
-
- const Editflags: array [ TEditOption ] of Integer = (
- not (ES_AUTOHSCROLL or WS_HSCROLL),
- not (es_AutoVScroll or WS_VSCROLL),
- es_Lowercase, es_Multiline,
- es_NoHideSel, es_OemConvert, es_Password, es_Readonly,
- es_UpperCase, es_WantReturn, 0, es_Number );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewEditbox]
- function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
- begin
- new( Result, CreateEditbox( AParent, Options ) );
- end;
- //[END NewEditbox]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewEditBox]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewEditbox( AParent: PControl; Options: TEditOptions ) : PControl;
- var Flags: Integer;
- begin
- Flags := MakeFlags( @Options, EditFlags );
- if not(eoMultiline in Options) then
- Flags := Flags and not(WS_HSCROLL or WS_VSCROLL);
- Result := _NewControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP
- or WS_BORDER or Flags, True, @EditActions );
- with Result.fBoundsRect do
- begin
- Right := Left + 100;
- Bottom := Top + 22;
- if eoMultiline in Options then
- begin
- Right := Right + 100;
- Bottom := Top + 200;
- Result.fIgnoreDefault := TRUE;
- end;
- end;
- Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
- if eoMultiline in Options then
- Result.fLookTabKeys := [ tkTab ];
- if eoWantTab in Options then
- Result.fLookTabKeys := Result.fLookTabKeys - [ tkTab ];
- end;
- {$ENDIF ASM_VERSION}
- //[END NewEditBox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== List box ========================//
-
- const ListFlags: array[TListOption] of Integer = (
- LBS_DISABLENOScroll, not LBS_ExtendedSel,
- LBS_MultiColumn or WS_HSCROLL,
- LBS_MultiPLESel,
- LBS_NoIntegralHeight, LBS_NoSel, LBS_Sort, LBS_USETabstops,
- not LBS_HASSTRINGS, LBS_NODATA, LBS_OWNERDRAWFIXED,
- LBS_OWNERDRAWVARIABLE, WS_HSCROLL );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewListbox]
- function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
- begin
- new( Result, CreateListbox( AParent, Options ) );
- end;
- //[END NewListbox]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewListbox]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewListbox( AParent: PControl; Options: TListOptions ): PControl;
- var Flags: Integer;
- begin
- Flags := MakeFlags( @Options, ListFlags );
- Result := _NewControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP
- or WS_BORDER or WS_VSCROLL
- or LBS_NOTIFY or Flags, True, @ListActions );
- with Result.fBoundsRect do
- begin
- Right := Right + 100;
- Bottom := Top + 200;
- end;
- Result.fColor := clWindow;
- Result.fLookTabKeys := [ tkTab, tkLeftRight ];
- end;
- {$ENDIF ASM_VERSION}
- //[END NewListbox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Combo box ========================//
-
- //[FUNCTION ComboboxDropDown]
- {$IFNDEF USE_DROPDOWNCOUNT}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure ComboboxDropDown( Sender: PObj );
- var
- CB: PControl;
- IC: Integer;
- begin
- CB := PControl( Sender );
- IC := CB.Count;
- if IC > 8 then IC := 8;
- if IC < 1 then IC := 1;
- {$ifdef wince}
- SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,
- SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or
- SWP_SHOWWINDOW);
- {$else}
- SetWindowPos( CB.Handle, 0, 0, 0, CB.Width, CB.Height * (IC + 1) + 2,
- SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_NOREDRAW +
- SWP_HIDEWINDOW);
-
- SetWindowPos( CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
- + SWP_NOZORDER + SWP_NOACTIVATE
- + SWP_NOREDRAW + SWP_SHOWWINDOW);
- {$endif wince}
- if assigned( CB.fOnDropDown ) then
- CB.fOnDropDown( CB );
-
- end;
- {$ENDIF ASM_VERSION}
- {$ELSE newcode}
- procedure ComboboxDropDown( Sender: PObj );
- var
- CB: PControl;
- Count: Integer;
- DropDownCount: Integer;
- ItemHeight: Integer;
- begin
- CB := PControl(Sender);
-
- Count := CB.Count;
- DropDownCount := CB.DropDownCount;
- if (Count > DropDownCount) then
- Count := DropDownCount;
- if (Count < 1) then
- Count := 1;
- ItemHeight := CB.Perform(CB_GETITEMHEIGHT, 0, 0);
- {$ifdef wince}
- SetWindowPos(
- CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,
- SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);
- {$else}
- SetWindowPos(
- CB.Handle, 0, 0, 0, CB.Width, ItemHeight * Count + CB.Height + 2,
- SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOREDRAW or SWP_HIDEWINDOW);
- SetWindowPos(
- CB.Handle, 0, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER or
- SWP_NOACTIVATE or SWP_NOREDRAW or SWP_SHOWWINDOW);
- {$endif wince}
- if Assigned(CB.fOnDropDown) then
- CB.fOnDropDown(CB);
- end;
- {$ENDIF USE_DROPDOWNCOUNT}
- //[END ComboboxDropDown]
-
- //[function WndFuncCombo]
- function WndFuncCombo( W: HWnd; Msg: Cardinal; wParam, lParam: Integer )
- : Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var Combo, Form: PControl;
- ParentWnd : HWnd;
- MsgStruct: TMsg;
- PrevProc:Pointer; //********************************** Added By M.Gerasimov
- begin
- Combo := nil;
-
- ParentWnd := GetParent( W );
- if ParentWnd <> 0 then
- {$IFDEF USE_PROP}
- Combo := Pointer( GetProp( ParentWnd, ID_SELF ) );
- {$ELSE}
- Combo := Pointer( GetWindowLong( ParentWnd, GWL_USERDATA ) );
- {$ENDIF}
-
- if Combo <> nil then
- begin
- MsgStruct.hwnd := Combo.fHandle;
- MsgStruct.message := Msg;
- MsgStruct.wParam := wParam;
- MsgStruct.lParam := lParam;
- Form := Combo.ParentForm;
- if fGlobalProcKeybd( Combo, MsgStruct, Result ) then Exit;
- if W <> Combo.FHandle then
- begin
- if Assigned( Applet ) and Assigned( Applet.OnMessage ) then
- if Applet.OnMessage( MsgStruct, Result ) then Exit;
- if (Applet <> Form) and (Form <> nil) then
- if Assigned( Form.OnMessage ) then
- if Form.OnMessage( MsgStruct, Result ) then Exit;
- end;
- if //(GetFocus = W) and
- (Msg = WM_KEYDOWN) or (Msg = WM_KEYUP) or (Msg = WM_CHAR) then
- begin
- Result := 0;
- if (wParam = VK_TAB) then
- begin
- case Msg of
- WM_KEYDOWN:
- if Assigned( Combo.fGotoControl ) and
- Combo.fGotoControl( Combo, wParam, FALSE ) then Exit;
- else Exit;
- end;
- end
- else
- if (Msg = WM_CHAR) and ((wParam = VK_ESCAPE) or (wParam = VK_RETURN)) then
- begin
- if Combo.Perform( CB_GETDROPPEDSTATE, 0, 0 ) <> 0 then
- begin
- Combo.Perform( CB_SHOWDROPDOWN, 0, 0 );
- if wParam = VK_ESCAPE then
- Combo.Perform( CB_SETCURSEL, Combo.fCurIdxAtDrop, 0 );
- Combo.fWndProcKeybd( Combo, MsgStruct, Result );
- Exit;
- end
- {$IFDEF ESC_CLOSE_DIALOGS}
- //---------------------------------Babenko Alexey--------------------------
- else
- if (wparam = VK_ESCAPE) then
- if (combo.ParentForm.ExStyle and WS_EX_DLGMODALFRAME) <> 0 then begin
- SendMessage(combo.ParentForm.Handle, WM_CLOSE, 0, 0);
- exit;
- end;
- {$ENDIF}
- end;
- Combo.fWndProcKeybd( Combo, MsgStruct, Result );
- end
- else
- if Msg = WM_SETFOCUS then
- begin
- if Form <> nil then Form.fCurrentControl := Combo;
- end;
- MsgStruct.hwnd := W;
- //********************************************************* Added By M.Gerasimov
- PrevProc:=Pointer(GetProp( W, ID_PREVPROC ));
- if PrevProc <> Nil then
- Result := CallWindowProc( PrevProc , W, MsgStruct.message,
- MsgStruct.wParam, MsgStruct.lParam )
- else
- Result:=0;
- //*********************************************************
- end
- else
- Result := DefWindowProc( W, Msg, wParam, lParam );
- end;
-
- //[PROCEDURE CreateComboboxWnd]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure CreateComboboxWnd( Combo: PControl );
- var W : HWND;
- PrevProc: DWORD;
- begin
- W := GetWindow( Combo.fHandle, GW_CHILD );
- {if W <> 0 then
- W := GetWindow( W, GW_HWNDNEXT );}
- while W <> 0 do
- begin
- PrevProc :=
- SetWindowLong( W, GWL_WNDPROC, Longint( @WndFuncCombo ) );
- SetProp( W, ID_PREVPROC, PrevProc ); //
- W := GetWindow( W, GW_HWNDNEXT );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END CreateComboboxWnd]
-
- //[procedure RemoveChldPrevProc]
- procedure RemoveChldPrevProc( fHandle: HWnd );
- var Chld: HWnd;
- begin
- Chld := GetWindow( fHandle, GW_CHILD );
- while Chld <> 0 do
- begin
- if GetProp( Chld, ID_PREVPROC ) <> 0 then
- RemoveProp(Chld, ID_PREVPROC);
- Chld := GetWindow( Chld, GW_HWNDNEXT );
- end;
- end;
-
- //[function WndProcCombo]
- function WndProcCombo( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if (Msg.message >= WM_CTLCOLORMSGBOX) and (Msg.message <= WM_CTLCOLORSTATIC) then
- begin
- Rslt := Sender.Perform( Msg.message + CN_BASE, Msg.wParam, Msg.lParam );
- Result := TRUE;
- end
- else
- if (Msg.message >= CN_CTLCOLORMSGBOX) and (Msg.message <= CN_CTLCOLORSTATIC) then
- begin
- if Sender.fTransparent then
- case Msg.message of
- CN_CTLCOLORLISTBOX:
- begin
- SetBkMode( Msg.wParam, Windows.OPAQUE );
- SetBkColor(Msg.WParam, Color2RGB( Sender.fColor ) );
- Rslt := Global_GetCtlBrushHandle( Sender );
- Result := TRUE;
- end;
- end;
- end
- else
- if Msg.message = CM_COMMAND then
- begin
- case HiWord( Msg.wParam ) of
- CBN_DROPDOWN:
- begin
- Sender.fDropped := True;
- Sender.fCurIdxAtDrop := Sender.CurIndex;
- Sender.fDropDownProc( Sender );
- end;
- CBN_CLOSEUP:
- begin
- Sender.fDropped := False;
- if Assigned( Sender.fOnCloseUp ) then Sender.fOnCloseUp( Sender );
- end;
- CBN_SELCHANGE:
- begin
- PostMessage( Sender.fHandle, CM_COMMAND, CM_CBN_SELCHANGE shl 16, 0 );
- end;
- end;
- end
- else
- if Msg.message = WM_DESTROY then
- RemoveChldPrevProc( Sender.Handle );
- end;
-
- const ComboFlags: array[ TComboOption ] of Integer = (
- CBS_DROPDOWNLIST, not CBS_AUTOHScroll,
- CBS_DISABLENOSCROLL, CBS_LowerCase, CBS_NoIntegralHeight,
- CBS_OemConvert, CBS_Sort, CBS_UpperCase, {$ifndef wince}
- CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_SIMPLE {$else} 0,0,0 {$endif wince} );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewCombobox]
- function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
- begin
- new( Result, CreateCombobox( AParent, Options ) );
- end;
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewCombobox]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewCombobox( AParent: PControl; Options: TComboOptions ): PControl;
- var Flags: Integer;
- begin
- Flags := MakeFlags( @Options, ComboFlags );
- {$ifndef wince}
- if not LongBool( Flags and CBS_SIMPLE ) then
- {$endif wince}
- Flags := Flags or CBS_DROPDOWN;
- Result := _NewControl( AParent, 'COMBOBOX',
- WS_VISIBLE
- or WS_CHILD
- or WS_VSCROLL
- or CBS_HASSTRINGS or WS_TABSTOP
- or Flags
- , True, @ComboActions );
- //Result.fCannotDoubleBuf := TRUE;
- Result.fCreateWndExt := CreateComboboxWnd;
- Result.fDropDownProc := ComboboxDropDown;
- Result.fClsStyle := Result.fClsStyle or CS_DBLCLKS;
- with Result.fBoundsRect do
- begin
- Right := Left + 100;
- Bottom := Top + 22;
- end;
- Result.fLookTabKeys := [ tkTab ];
- if coReadOnly in Options then
- Result.fLookTabKeys := [ tkTab, tkLeftRight ];
- Result.AttachProc( @ WndProcCombo );
- {$IFDEF USE_DROPDOWNCOUNT}
- Result.DropDownCount := 8;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewCombobox]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //[FUNCTION WndProcResiz]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- C: PControl;
- begin
- if Msg.message = WM_SIZE then
- begin
- for I:= 0 to Self_.fChildren.fCount - 1 do
- begin
- C := Self_.fChildren.fItems[ I ];
- C.Perform( CM_SIZE, 0, 0 );
- end;
- end;
- Result := False; // don't stop further processing
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcResiz]
-
- //[FUNCTION WndProcParentResize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcParentResize(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := False;
- case Msg.message of
- CM_SIZE:
- begin
- Self_.Perform( WM_SIZE, 0, 0 );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcParentResize]
-
- //[procedure InitCommonControlCommonNotify]
- procedure InitCommonControlCommonNotify( Ctrl: PControl );
- var AParent: PControl;
- begin
- Ctrl.fIsCommonControl := True;
- AParent := Ctrl.Parent;
- if AParent <> nil then
- begin
- Ctrl.AttachProc( WndProcCommonNotify );
- AParent.AttachProc( WndProcNotify );
- end;
- end;
-
- //[procedure InitCommonControlSizeNotify]
- procedure InitCommonControlSizeNotify( Ctrl: PControl );
- var AParent: PControl;
- begin
- AParent := Ctrl.Parent;
- if AParent <> nil then
- begin
- Ctrl.AttachProc( WndProcParentResize );
- AParent.AttachProc( WndProcResize );
- end;
- end;
-
- //[function _NewCommonControl]
- function _NewCommonControl( AParent: PControl; ClassName: PKOLChar; Style: DWORD;
- Ctl3D: Boolean; Actions: PCommandActions ): PControl;
- begin
- {*************} DoInitCommonControls( ICC_WIN95_CLASSES );
- Result := _NewControl( AParent, ClassName, Style, Ctl3D, Actions );
- InitCommonControlCommonNotify( Result );
- end;
-
- //==================== Progress bar ======================//
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewProgressbar]
- function NewProgressbar( AParent: PControl ): PControl;
- begin
- new( Result, CreateProgressbar( AParent ) );
- end;
- //[END NewProgressbar]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewProgressbar]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewProgressbar( AParent: PControl ): PControl;
- begin
- Result := _NewCommonControl( AParent, PROGRESS_CLASS,
- WS_CHILD or WS_VISIBLE{$ifdef wince} or WS_BORDER{$endif}, True, nil );
- with Result.fBoundsRect do
- begin
- Right := Left + 300;
- Bottom := Top + 20;
- end;
- Result.fMenu := 0;
- Result.fTextColor := clHighlight;
- {$ifdef win32}
- Result.fCommandActions.aSetBkColor := PBM_SETBKCOLOR;
- {$endif win32}
- //Result.fNCDestroyed := TRUE; // do not call DestroyWindow!
- end;
- {$ENDIF ASM_VERSION}
- //[END NewProgressbar]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewProgressbarEx]
- function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
- begin
- new( Result, CreateProgressbarEx( AParent, Options ) );
- end;
- //[END NewProgressbarEx]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewProgressbarEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewProgressbarEx( AParent: PControl; Options: TProgressbarOptions ): PControl;
- const ProgressBarFlags: array[ TProgressbarOption ] of Integer =
- (PBS_VERTICAL, PBS_SMOOTH );
- begin
- Result := NewProgressbar( AParent );
- Result.fStyle := Result.fStyle or DWORD( MakeFlags( @Options, ProgressBarFlags ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END NewProgressbarEx]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== List view ========================//
-
- //[FUNCTION WndProcNotify]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NMhdr: PNMHdr;
- Child: PControl;
- begin
- Result := False;
- if Msg.message = WM_NOTIFY then
- begin
- NMhdr := Pointer( Msg.lParam );
- {$IFDEF USE_PROP}
- Child := Pointer( GetProp( NMhdr.hwndFrom, ID_SELF ) );
- {$ELSE}
- Child := Pointer( GetWindowLong( NMhdr.hwndFrom, GWL_USERDATA ) );
- {$ENDIF}
- if Child <> nil then
- begin
- Msg.hwnd := Child.fHandle;
- Result := EnumDynHandlers( Child, Msg, Rslt );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcNotify]
-
- //[FUNCTION WndProcCommonNotify]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcCommonNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NMhdr: PNMHdr;
- begin
- Result := False;
- if Msg.message = WM_NOTIFY then
- begin
- NMHdr := Pointer( Msg.lParam );
- case LongInt(NMHdr.code) of
- NM_RCLICK,
- NM_CLICK: if assigned( Self_.fOnClick ) then
- begin
- Self_.fRightClick := LongInt(NMHdr.code)=NM_RCLICK;
- Self_.fOnClick( Self_ );
- Result := TRUE;
- end;
- NM_KILLFOCUS: if assigned( Self_.fOnLeave ) then
- Self_.fOnLeave( Self_ );
- NM_RETURN,
- NM_SETFOCUS: if assigned( Self_.fOnEnter ) then
- Self_.fOnEnter( Self_ );
- {$ifdef wince}
- NM_RECOGNIZEGESTURE:
- begin
- Rslt:=1;
- Result:=True;
- end;
- {$endif wince}
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcCommonNotify]
-
- const ListViewStyles: array[ TListViewStyle ] of DWORD = ( LVS_ICON, LVS_SMALLICON,
- LVS_LIST, LVS_REPORT, LVS_REPORT or LVS_NOCOLUMNHEADER );
- ListViewFlags: array[ TListViewOption ] of Integer = ( LVS_ALIGNLEFT, LVS_AUTOARRANGE,
- $400 {LVS_BUTTON}, LVS_EDITLABELS, LVS_NOLABELWRAP,
- LVS_NOSCROLL, LVS_NOSORTHEADER,
- not LVS_SHOWSELALWAYS, not LVS_SINGLESEL, LVS_SORTASCENDING,
- LVS_SORTDESCENDING, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- LVS_OWNERDATA, LVS_OWNERDRAWFIXED );
-
- ListViewExFlags: array[ TListViewOption ] of Integer = ( 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, LVS_EX_GRIDLINES,
- LVS_EX_SUBITEMIMAGES, LVS_EX_CHECKBOXES, LVS_EX_TRACKSELECT,
- LVS_EX_HEADERDRAGDROP, LVS_EX_FULLROWSELECT, LVS_EX_ONECLICKACTIVATE,
- {$ifdef win32}LVS_EX_TWOCLICKACTIVATE, LVS_EX_FLATSB, LVS_EX_REGIONAL,
- LVS_EX_INFOTIP, LVS_EX_UNDERLINEHOT, LVS_EX_MULTIWORKAREAS,{$else}
- 0, 0, 0, 0, 0, 0,{$endif win32}0, 0 );
-
- //[FUNCTION ApplyImageLists2Control]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure ApplyImageLists2Control( Sender: PControl );
- var IL: PImageList;
- begin
- if Sender.fCommandActions.aSetImgList = 0 then Exit;
- IL := Sender.ImageListNormal;
- if IL <> nil then
- Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_NORMAL, IL.Handle );
- IL := Sender.ImageListSmall;
- if IL <> nil then
- Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_SMALL, IL.Handle );
- IL := Sender.ImageListState;
- if IL <> nil then
- Sender.Perform( Sender.fCommandActions.aSetImgList, LVSIL_STATE, IL.Handle );
- end;
- {$ENDIF ASM_VERSION}
- //[END ApplyImageLists2Control]
-
- //[FUNCTION ApplyImageLists2ListView]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure ApplyImageLists2ListView( Sender: PControl );
- var Flags: DWORD;
- begin
- Flags := MakeFlags( @Sender.fLVOptions, ListViewFlags );
- Sender.Style := Sender.Style and not $403F
- or Flags or ListViewStyles[ Sender.fLVStyle ];
- Flags := MakeFlags( @Sender.fLVOptions, ListViewExFlags );
- Sender.Perform( LVM_SETEXTENDEDLISTVIEWSTYLE, $3FFF, Flags );
- ApplyImageLists2Control( Sender );
- end;
- {$ENDIF ASM_VERSION}
- //[END ApplyImageLists2ListView]
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewListView]
- function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
- ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
- begin
- new( Result, CreateListView( AParent, Style, Options, ImageListSmall,
- ImageListNormal, ImageListState ) );
- end;
- //[END NewListView]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewListView]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewListView( AParent: PControl; Style: TListViewStyle; Options: TListViewOptions;
- ImageListSmall, ImageListNormal, ImageListState: PImageList ): PControl;
- begin
- Result := _NewCommonControl( AParent, WC_LISTVIEW,
- ListViewStyles[ Style ] or LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE
- or WS_TABSTOP or WS_CLIPCHILDREN{$ifdef wince} or WS_BORDER{$endif}
- or DWORD( MakeFlags( @Options, ListViewFlags ) ),
- True, @ListViewActions );
-
- Result.fLVOptions := Options;
- Result.fLVStyle := Style;
- Result.fCreateWndExt := ApplyImageLists2ListView;
- with Result.fBoundsRect do
- begin
- Right := Left + 200;
- Bottom := Top + 150;
- end;
- Result.ImageListSmall := ImageListSmall;
- Result.ImageListNormal := ImageListNormal;
- Result.ImageListState := ImageListState;
- Result.fLVTextBkColor := clWindow;
- Result.fLookTabKeys := [ tkTab ];
- //Result.fMargin := 0;
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewListView]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Tree view ========================//
-
- //[FUNCTION WndProcTreeView]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcTreeView( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NM: PNMTreeView;
- DI: PTVDispInfo;
- P: TPoint;
- S: KOL_String;
- begin
- if Msg.message = WM_NOTIFY then
- begin
- NM := Pointer( Msg.lParam );
- case LongInt(NM.hdr.code) of
- NM_RCLICK:
- begin
- GetCursorPos( P );
- P := Self_.Screen2Client( P );
- PostMessage( Self_.fHandle, WM_RBUTTONUP, MK_RBUTTON or GetShiftState,
- (P.x and $FFFF) or (P.y shl 16) );
- end;
- (*{$IFNDEF UNICODE_CTRLS}
- TVN_BEGINDRAGW, TVN_BEGINRDRAGW,
- {$ENDIF}*)
- TVN_BEGINDRAG {$IFDEF TV_DRAG_RBUTTON}, TVN_BEGINRDRAG{$ENDIF}:
- if Assigned( Self_.fOnTVBeginDrag ) then
- Self_.fOnTVBeginDrag( Self_, NM.itemNew.hItem );
- TVN_BEGINLABELEDIT
- (*{$IFNDEF UNICODE_CTRLS}, TVN_BEGINLABELEDITW{$ENDIF}*):
- begin
- if Self_.fDragging
- {$ifdef wince}
- or ((Self_.fAutoPopupMenu <> nil) and LongBool(PMenu(Self_.fAutoPopupMenu).Flags and $1000))
- {$endif wince}
- then
- begin
- Rslt := 1; // do not allow edit while dragging
- Result := TRUE;
- Exit;
- end;
- DI := Pointer( NM );
- if Assigned( Self_.fOnTVBeginEdit ) then
- begin
- Rslt := Integer( not Self_.fOnTVBeginEdit( Self_, DI.item.hItem ) );
- if Rslt = 0 then begin
- Self_.fEditing := TRUE;
- {$ifdef wince}
- SHSipPreference(Self_.ParentForm.fHandle, SIP_UP);
- {$endif wince}
- end;
- Result := TRUE;
- Exit;
- end;
- end;
- TVN_ENDLABELEDIT
- (*{$IFNDEF UNICODE_CTRLS}, TVN_ENDLABELEDITW {$ENDIF}*):
- begin
- {$ifdef wince}
- SHSipPreference(Self_.ParentForm.fHandle, SIP_DOWN);
- {$endif wince}
- DI := Pointer( NM );
- if Assigned( Self_.fOnTVEndEdit ) then
- begin
- S := DI.item.pszText;
- if (DI.item.pszText = nil) then
- begin
- Self_.fEditing := FALSE;
- Result := True;
- Exit;
- end;
- if Self_.fOnTVEndEdit( Self_, DI.item.hItem, S ) then Rslt := 1
- else Rslt := 0;
- //Self_.TVItemText[ DI.item.hItem ] := S; // MTsVN: ×òîáû ìîæíî áûëî ïîäðåäàêòèðîâàòü NewTxt â fOnTVEndEdit
- // VK: ýòî ïðåêðàñíî ìîæíî ñäåëàòü â îáðàáîò÷èêå ïîëüçîâàòåëÿ, åñëè åìó ýòî íóæíî. ß òàê âñåãäà è äåëàë.
- end
- else
- Rslt := 1;
- Self_.fEditing := FALSE;
- Result := True;
- Exit;
- end;
- TVN_ITEMEXPANDING
- (*{$IFNDEF UNICODE_CTRLS}, TVN_ITEMEXPANDINGW {$ENDIF}*):
- begin
- if Assigned( Self_.fOnTVExpanding ) then
- begin
- Rslt := Integer( Self_.fOnTVExpanding( Self_, NM.itemNew.hItem,
- NM.action = TVE_EXPAND ) );
- Result := TRUE;
- Exit;
- end;
- end;
- TVN_ITEMEXPANDED
- (*{$IFNDEF UNICODE_CTRLS}, TVN_ITEMEXPANDEDW {$ENDIF}*):
- if Assigned( Self_.fOnTVExpanded ) then
- Self_.fOnTVExpanded( Self_, NM.itemNew.hItem, NM.action=TVE_EXPAND );
- TVN_SELCHANGING
- (*{$IFNDEF UNICODE_CTRLS}, TVN_SELCHANGINGW {$ENDIF}*):
- begin //------------------ TVN_SELCHANGING by Sergey Shisminzev
- if Assigned( Self_.fOnTVSelChanging ) then
- begin
- Rslt := Integer( not Self_.fOnTVSelChanging( Self_, NM.itemOld.hItem, NM.itemNew.hItem ) );
- Result := TRUE;
- Exit;
- end;
- end; //----------------------------------------
- TVN_SELCHANGED
- (*{$IFNDEF UNICODE_CTRLS}, TVN_SELCHANGEDW {$ENDIF}*):
- Self_.DoSelChange;
- end;
- end;
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcTreeView]
-
- //[function ProcTVDeleteItem]
- function ProcTVDeleteItem( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NM: PNMTreeView;
- begin
- if Msg.message = WM_NOTIFY then
- begin
- NM := Pointer( Msg.lParam );
- case LongInt(NM.hdr.code) of
- TVN_DELETEITEM:
- if Assigned( Self_.fOnTVDelete ) then
- Self_.fOnTVDelete( Self_, NM.itemOld.hItem );
- end;
- end;
- Result := FALSE;
- end;
-
- //[procedure ClearTreeView]
- procedure ClearTreeView( TV: PControl );
- begin
- TV.TVDelete( TVI_ROOT );
- end;
-
- const
- TreeViewFlags: array[ TTreeViewOption ] of Integer = ( not TVS_HASLINES, TVS_LINESATROOT,
- not TVS_HASBUTTONS, TVS_EDITLABELS, not TVS_SHOWSELALWAYS,
- not TVS_DISABLEDRAGDROP,
- {$ifdef win32}TVS_NOTOOLTIPS, TVS_CHECKBOXES, TVS_TRACKSELECT, TVS_SINGLEEXPAND,
- TVS_INFOTIP, TVS_FULLROWSELECT, TVS_NOSCROLL, TVS_NONEVENHEIGHT
- {$else}0, TVS_CHECKBOXES, 0, TVS_SINGLEEXPAND, 0, 0, 0, 0
- {$endif win32});
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewTreeView]
- function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
- ImgListNormal, ImgListState: PImageList ): PControl;
- begin
- new( Result, CreateTreeView( AParent, Options, ImgListNormal, ImgListState ) );
- end;
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewTreeView]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewTreeView( AParent: PControl; Options: TTreeViewOptions;
- ImgListNormal, ImgListState: PImageList ): PControl;
- var Flags: Integer;
- begin
- Flags := MakeFlags( @Options, TreeViewFlags );
- Result := _NewCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or
- WS_CHILD or WS_TABSTOP{$ifdef wince} or WS_BORDER{$endif}, True, @TreeViewActions );
- Result.fCreateWndExt := ApplyImageLists2Control;
- Result.fColor := clWindow;
- Result.AttachProc( WndProcTreeView );
- with Result.fBoundsRect do
- begin
- Right := Left + 150;
- Bottom := Top + 200;
- end;
- Result.ImageListNormal := ImgListNormal;
- Result.ImageListState := ImgListState;
- Result.fLookTabKeys := [ tkTab ];
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewTreeView]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Tab Control ========================//
-
- //[FUNCTION WndProcTabControl]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcTabControl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Hdr: PNMHdr;
- A: Integer;
- R: TRect;
- WasActive: Boolean;
- I: Integer;
- {$IFDEF OLD_ALIGN}
- Page: PControl;
- begin
- case Msg.message of
- WM_NOTIFY:
- begin
- Hdr := Pointer( Msg.lParam );
- case LongInt(Hdr.code) of
- TCN_SELCHANGING:
- Self_.fCurIndex := Self_.GetCurIndex;
- TCN_SELCHANGE:
- begin
- A := {Self_.????}Self_.GetCurIndex;
- WasActive := Self_.fCurIndex = A;
- Self_.fCurIndex := A;
- for I := 0 to Self_.Count - 1 do
- begin
- Page := Self_.Pages[ I ];
- Page.Visible := A = I;
- if A = I then
- Page.BringToFront;
- end;
- if not WasActive then
- if Assigned( Self_.fOnSelChange ) then
- Self_.fOnSelChange( Self_ );
- if Assigned(Self_.fGotoControl) and not Self_.Focused then begin
- Self_.ParentForm.fCurrentControl:=Self_;
- Self_.fGotoControl(Self_, VK_TAB, False);
- end;
- end;
- end;
- end;
- WM_SIZE:
- begin
- R:=Self_.TC_DisplayRect;
- for I := 0 to Self_.Count - 1 do
- begin
- Page := Self_.Pages[ I ];
- Page.BoundsRect := R;
- end;
- {$ELSE NEW_ALIGN}
- begin
- case Msg.message of
- WM_NOTIFY:
- begin
- Hdr := Pointer( Msg.lParam );
- case longint(Hdr.code) of
- TCN_SELCHANGING:
- Self_.fCurIndex := Self_.GetCurIndex;
- TCN_SELCHANGE:
- begin
- A := Self_.GetCurIndex;
- WasActive := Self_.fCurIndex = A;
- if (not WasActive)and(Self_.fCurIndex>=0) then
- Self_.Pages[Self_.fCurIndex].Visible := false;
- Self_.fCurIndex := A;
- Self_.Pages[Self_.fCurIndex].Visible := true;
- Self_.Pages[Self_.fCurIndex].BringToFront;
- if not WasActive then
- if Assigned( Self_.fOnSelChange ) then
- Self_.fOnSelChange( Self_ );
- if Assigned(Self_.fGotoControl) and not Self_.Focused then begin
- Self_.ParentForm.fCurrentControl:=Self_;
- Self_.fGotoControl(Self_, VK_TAB, False);
- end;
- end;
- end;
- end;
- WM_SIZE:
- begin
- GetClientRect( Self_.fHandle, R );
- Self_.fClientRight := R.Right;
- Self_.fClientBottom := R.Bottom;
- Self_.Perform( TCM_ADJUSTRECT, 0, Integer( @R ) );
- Self_.fClientLeft := R.Left;
- Self_.fClientTop := R.Top;
- Dec(Self_.fClientRight,R.Right);
- Dec(Self_.fClientBottom,R.Bottom);
- {$ifdef wince}
- with Self_^ do begin
- Dec(fClientTop, fMargin + 2);
- Dec(fClientLeft, fMargin + 2);
- Dec(fClientRight, fMargin + 2);
- Dec(fClientBottom, fMargin);
- end;
- {$endif wince}
- // This fixes anchoring problems on invisible tabs
- A := Self_.CurIndex;
- R:=Self_.ClientRect;
- for I := 0 to Self_.Count - 1 do
- if I <> A then
- Self_.Pages[ I ].BoundsRect := R;
- {$ENDIF}
- end;
- WM_SHOWWINDOW:
- if WordBool(Msg.wParam) and Self_.Focused then
- PostMessage(Self_.fHandle, WM_KEYDOWN, VK_TAB, 1);
- end;
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcTabControl]
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- {$DEFINE RICHEDIT_XPBORDER}
- {$ENDIF}
-
- {$IFDEF RICHEDIT_XPBORDER}
- function WndProc_RichEditXPBorder( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var ExStyle: DWORD;
- DrawRect, EmptyRect: TRect;
- DC: HDC;
- Details: TThemedElementDetails;
- begin
- Result := FALSE;
- if Msg.message = WM_NCPAINT then
- begin
- ExStyle := GetWindowLong(Self_.Handle, GWL_EXSTYLE);
- if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
- begin
- GetWindowRect(Self_.Handle, DrawRect);
- OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
- DC := GetWindowDC(Self_.Handle);
- //try
- EmptyRect := DrawRect;
- with DrawRect do
- ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
- //Details := GetElementDetails(teEditTextNormal);
- Details.Element := teEdit;
- Details.Part := 1 {EP_EDITTEXT};
- Details.State := Ord(teEditTextNormal) - Ord(teEditTextNormal) + 1;
- //DrawElement(DC, Details, DrawRect);
- if not Assigned( DrawThemeBackground ) then
- begin
- ThemeLibrary := LoadLibrary(themelib);
- DrawThemeBackground := GetProcAddress(ThemeLibrary, 'DrawThemeBackground');
- OpenThemeData := GetProcAddress(ThemeLibrary, 'OpenThemeData');
- end;
- if Assigned( DrawThemeBackground ) then
- begin
- Result := TRUE;
- Rslt := Self_.CallDefWndProc( Msg );
- with Details do
- DrawThemeBackground(OpenThemeData(0, 'edit'),
- DC, Part, State, DrawRect, nil);
- end;
- //finally
- ReleaseDC(Self_.Handle, DC);
- //end;
- end;
- end;
- end;
- {$ENDIF RICHEDIT_XPBORDER}
-
- const TabControlFlags: array[ TTabControlOption ] of Integer = ( TCS_BUTTONS,
- TCS_FIXEDWIDTH, not TCS_FOCUSNEVER,
- TCS_FIXEDWIDTH or TCS_FORCEICONLEFT, TCS_FIXEDWIDTH or TCS_FORCELABELLEFT,
- TCS_MULTILINE, TCS_MULTISELECT, TCS_RIGHTJUSTIFY, TCS_SCROLLOPPOSITE,
- TCS_BOTTOM, TCS_VERTICAL, TCS_FLATBUTTONS, TCS_HOTTRACK, 0, TCS_OWNERDRAWFIXED );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewTabControl]
- function NewTabControl( AParent: PControl; Tabs: array of String; Options: TTabControlOptions;
- ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
- begin
- new( Result, CreateTabControl( AParent, Tabs, Options, ImgList, ImgList1stIdx ) );
- end;
- //[END NewTabControl]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewTabControl]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewTabControl( AParent: PControl; const Tabs: array of KOLString; Options: TTabControlOptions;
- ImgList: PImageList; ImgList1stIdx: Integer ): PControl;
- var I, II : Integer;
- Flags: Integer;
- begin
- Flags := MakeFlags( @Options, TabControlFlags );
- if tcoFocusTabs in Options then
- Flags := Flags or TCS_FOCUSONBUTTONDOWN;
- Result := _NewCommonControl( AParent, WC_TABCONTROL,
- Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE or WS_TABSTOP{$ifdef wince} or WS_BORDER or TCS_BOTTOM{$endif}), True,
- @TabControlActions );
- {$ifndef wince}
- if not( tcoBorder in Options ) then
- begin
- Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
- end;
- {$endif wince}
- Result.AttachProc( WndProcTabControl );
- with Result.fBoundsRect do
- begin
- Right := Left + 100;
- Bottom := Top + 100;
- end;
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- if ImgList <> nil then
- Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
- II := ImgList1stIdx;
- for I := 0 to High( Tabs ) do
- begin
- Result.TC_Insert( I, Tabs[ I ], II );
- Inc( II );
- end;
- Result.fLookTabKeys := [ tkTab, tkUpDown ];
- end;
- {$ENDIF ASM_VERSION}
- //[END NewTabControl]
-
- {$IFNDEF OLD_ALIGN}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- //[FUNCTION NewTabEmpty]
- function NewTabEmpty( AParent: PControl; Options: TTabControlOptions;
- ImgList: PImageList ): PControl;
- var Flags: Integer;
- begin
- Flags := MakeFlags( @Options, TabControlFlags );
- if tcoFocusTabs in Options then
- Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN);
- Result := _NewCommonControl( AParent, WC_TABCONTROL,
- Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_VISIBLE), True,
- @TabControlActions );
- if not( tcoBorder in Options ) then
- Result.fExStyle := Result.fExStyle and not WS_EX_CLIENTEDGE;
- Result.AttachProc( WndProcTabControl );
- with Result.fBoundsRect do begin
- Right := Left + 100;
- Bottom := Top + 100;
- end;
- if ImgList <> nil then
- Result.Perform( TCM_SETIMAGELIST, 0, ImgList.Handle );
- Result.fLookTabKeys := [ tkTab ];
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewTabEmpty]
- {$ENDIF}
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //===================== Tool bar ========================//
-
- //[FUNCTION WndProcToolbarCtr]
- {$IFDEF ASM_noVERSION} //TTN_NEEDTEXTW
- function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- asm
- CMP word ptr [EDX].TMsg.message, WM_WINDOWPOSCHANGED
- JNE @@chk_CM_COMMAND
- MOV dword ptr [ECX], 0 // Rslt := 0
- MOV ECX, [EAX].TControl.fOnResize.TMethod.Code
- JECXZ @@ret_true
- XCHG EDX, EAX // Sender := Self_
- MOV EAX, [EDX].TControl.fOnResize.TMethod.Data
- CALL ECX // Self_.fOnResize
- XOR EAX, EAX // Result := FALSE
- RET
- @@chk_CM_COMMAND:
- CMP word ptr [EDX].TMsg.message, CM_COMMAND
- JNE @@chk_WM_NOTIFY
- MOVZX ECX, word ptr [EDX].TMsg.wParam
- MOV [EAX].TControl.fCurItem, ECX
- PUSH EAX
- PUSH 0
- PUSH ECX
- PUSH TB_COMMANDTOINDEX
- PUSH EAX
- CALL TControl.Perform
- PUSH EAX
-
- PUSH VK_RETURN
- CALL GetKeyState
- TEST EAX, EAX
- SETL DL
- POP ECX
- POP EAX
- MOV [EAX].TControl.fCurIndex, ECX
- MOV [EAX].TControl.fRightClick, DL
- @@ret_false:
- XOR EAX, EAX
- RET
-
- @@chk_WM_NOTIFY:
- CMP word ptr [EDX].TMsg.message, WM_NOTIFY
- JNE @@ret_false
- MOV EDX, [EDX].TMsg.lParam
- MOV ECX, [EDX].TTooltipText.hdr.code
- CMP ECX, TTN_NEEDTEXT
- JNE @@chk_NM_RCLICK
- PUSH EAX
- PUSH EDX
- MOV EDX, [EDX].TTooltipText.hdr.idFrom
- MOV ECX, [EAX].TControl.fTBttCmd
- OR EAX, -1
- JECXZ @@idxReady
- XCHG EAX, ECX
- CALL TList.IndexOf
- @@idxReady: // EAX = -1 or index of button tooltip
- TEST EAX, EAX
- POP EDX
- LEA EDX, [EDX].TTooltipText.szText
- MOV byte ptr [EDX], 0
- POP ECX
- JL @@ret_true
- MOV ECX, [ECX].TControl.fTBttTxt
- MOV ECX, [ECX].TStrList.fList
- MOV ECX, [ECX].TList.fItems
- MOV EAX, [ECX+EAX*4]
- XCHG EAX, EDX
- XOR ECX, ECX
- MOV CL, 79
- CALL StrLCopy
- JMP @@ret_true
- @@chk_NM_RCLICK:
- CMP ECX, NM_RCLICK
- JNE @@chk_NM_CLICK
- OR [EAX].TControl.fRightClick, 1
- MOV ECX, [EDX].TNMMouse.dwItemSpec
- MOV [EAX].TControl.fCurItem, -1
- PUSH EAX
- PUSH 0
- PUSH ECX
- PUSH TB_COMMANDTOINDEX
- PUSH EAX
- CALL TControl.Perform
- POP EDX
- MOV [EDX].TControl.fCurIndex, EAX
- XOR EAX, EAX
- RET
- @@chk_NM_CLICK:
- CMP ECX, NM_CLICK
- JNE @@chk_TBN_DROPDOWN
- MOV [EAX].TControl.fRightClick, 0
- OR [EAX].TControl.fCurItem, -1
- OR [EAX].TControl.fCurIndex, -1
- CMP [EDX].TTBNotify.iItem, -1
- SETNZ AL
- RET
- @@chk_TBN_DROPDOWN:
- CMP ECX, TBN_DROPDOWN
- JNE @@ret_false
- MOV EDX, [EDX].TTBNotify.iItem
- MOV [EAX].TControl.fCurItem, EDX
- PUSH EAX
- CALL TControl.TBItem2Index
- POP EDX
- MOV [EDX].TControl.fCurIndex, EAX
- MOV ECX, [EDX].TControl.fOnDropDown.TMethod.Code
- JECXZ @@ret_z
- MOV EAX, [EDX].TControl.fOnDropDown.TMethod.Data
- CALL ECX
- @@ret_z:
- XOR EAX, EAX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcToolbarCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- {$ifdef win32}
- var lpttt: PTooltipText;
- idBtn, Idx: Integer;
- {$endif win32}
- var Notify: PTBNotify;
- Mouse: PNMMouse;
- {$ifdef win32}
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- var Wstr: WideString;
- {$ENDIF _D2}
- {$ENDIF _FPC}
- {$endif win32}
- begin
- Result := False;
- if Msg.message = WM_WINDOWPOSCHANGED then
- begin
- if Assigned( Self_.fOnResize ) then
- Self_.fOnResize( Self_ );
- //Result := TRUE; // this prevents Align working for child controls of Toolbar !
- Rslt := 0;
- end
- else if Msg.message = CM_COMMAND then
- begin
- Self_.fCurItem := Loword( Msg.wParam );
- Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Loword( Msg.wParam ), 0 );
- Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;
- end
- else if Msg.message = WM_NOTIFY then
- begin
- {$ifdef win32}
- lpttt := Pointer( Msg.lParam );
- {$endif win32}
- Notify := Pointer( Msg.lParam );
- case LongInt(Notify.hdr.code) of
- {$ifdef win32}
- TTN_NEEDTEXT:
- begin
- Result := True;
- idBtn := lpttt.hdr.idFrom;
- Idx := -1;
- if Self_.fTBttCmd <> nil then
- Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );
- lpttt.szText[ 0 ] := #0;
- if Idx >= 0 then
- {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
- ( lpttt.szText, Self_.fTBttTxt.fList.fItems[ Idx ], 79 );
- Exit;
- end;
- {$IFNDEF _FPC}
- {$IFNDEF _D2}
- TTN_NEEDTEXTW: // for Windows XP
- begin
- Result := True;
- idBtn := lpttt.hdr.idFrom;
- Idx := -1;
- if Self_.fTBttCmd <> nil then
- Idx := Self_.fTBttCmd.IndexOf( Pointer( idBtn ) );
- FillChar( lpttt.szText[ 0 ], 160, #0 );
- if Idx >= 0 then
- begin
- WStr := Self_.fTBttTxt.Items[ Idx ];
- if WStr <> '' then
- Move( Wstr[ 1 ], lpttt.szText, Min( 158, (Length( WStr ) + 1) * 2 ) );
- end;
- Exit;
- end;
- {$ENDIF _D2}
- {$ENDIF _FPC}
- {$endif win32}
- NM_RCLICK:
- begin
- Mouse := Pointer( Msg.lParam );
- Self_.fCurItem := Mouse.dwItemSpec;
- Self_.fCurIndex := Self_.Perform( TB_COMMANDTOINDEX, Mouse.dwItemSpec, 0 );
- Self_.fRightClick := GetKeyState( VK_RBUTTON ) < 0;
- Self_.fRightClick := True;
- end;
- NM_CLICK:
- begin
- Self_.fCurItem := -1; // return CurItem = -1
- Self_.fCurIndex := -1;
- Self_.fRightClick := False;
- Result := Notify.iItem <> -1; // do not handle - if it will be handled in WM_COMMAND
- Exit;
- end;
- TBN_DROPDOWN:
- begin
- Self_.fCurItem := Notify.iItem;
- Self_.fCurIndex := Self_.TBItem2Index( Self_.fCurItem );
- if assigned( Self_.fOnDropDown ) then
- Self_.fOnDropDown( Self_ );
- end;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcToolbarCtr]
-
- const ToolbarAligns: array[ TControlAlign ] of DWORD =
- ( CCS_NOPARENTALIGN {or CCS_NOMOVEY} {or CCS_NORESIZE} or CCS_NODIVIDER, CCS_TOP or CCS_VERT, CCS_TOP, CCS_BOTTOM or CCS_VERT, CCS_BOTTOM,
- CCS_TOP );
- ToolbarOptions: array[ TToolbarOption ] of Integer = ( TBSTYLE_LIST, not TBSTYLE_LIST,
- TBSTYLE_FLAT, TBSTYLE_TRANSPARENT, TBSTYLE_WRAPABLE, CCS_NODIVIDER, 0,
- TBSTYLE_CUSTOMERASE );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewToolbar]
- function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
- Bitmap: HBitmap; Buttons: array of PChar;
- BtnImgIdxArray: array of Integer ) : PControl;
- begin
- new( Result, CreateToolbar( AParent, Align, Options, Bitmap, Buttons, BtnImgIdxArray ) );
- end;
- //[END NewToolbar]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewToolbar]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewToolbar( AParent: PControl; Align: TControlAlign; Options: TToolbarOptions;
- Bitmap: HBitmap; const Buttons: array of PKOLChar;
- const BtnImgIdxArray: array of Integer ) : PControl;
- var Flags: DWORD;
- begin
- if not( tboTextBottom in Options ) then
- Options := Options + [ tboTextRight ];
- if tboTextRight in Options then
- Options := Options - [ tboTextBottom ];
- Flags := MakeFlags( @Options, ToolbarOptions );
- {$ifdef wince}
- if tbo3DBorder in Options then
- Flags:=Flags or WS_BORDER;
- {$endif}
- DoInitCommonControls( ICC_BAR_CLASSES );
- Result := _NewCommonControl( AParent, TOOLBARCLASSNAME,
- (ToolbarAligns[ Align ] or WS_CHILD or WS_VISIBLE or TBSTYLE_TOOLTIPS
- or Flags and not (TBSTYLE_FLAT or TBSTYLE_TRANSPARENT)), {!ecm}
- tbo3DBorder in Options, nil );
- Result.fCommandActions.aClear := ClearToolbar;
- Result.fCommandActions.aGetCount := TB_BUTTONCOUNT;
- Result.fIsButton := TRUE;
- Result.fIgnoreDefault := TRUE;
- with Result.fBoundsRect do
- begin
- if Align in [ caNone ] then
- begin
- Bottom := Top + 26;
- Right := Left + 1000;
- end
- else
- begin
- Left := 0; Right := 0;
- Top := 0; Bottom := 0;
- end;
- end;
- Result.AttachProc( WndProcToolbarCtrl );
- Result.AttachProc( WndProcDoEraseBkgnd );
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- {$ifdef win32}
- Result.Perform(TB_SETEXTENDEDSTYLE, 0, Result.Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
- TBSTYLE_EX_DRAWDDARROWS);
- {$endif win32}
- Result.Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 );
- Result.Perform( TB_SETINDENT, Result.fMargin, 0 );
- with Result.fBoundsRect do
- begin
- if Align in [ caLeft, caRight ] then
- Right := Left + 24
- else if not (Align in [caNone]) then
- Bottom := Top + 22;
- end;
- if Bitmap <> 0 then
- Result.TBAddBitmap( Bitmap );
- Result.TBAddButtons( Buttons, BtnImgIdxArray );
- Result.Perform( WM_SIZE, 0, 0 );
- Result.Style := Result.Style or Flags; {+ecm}
- Result.fLookTabKeys := [ tkTab ];
- end;
- {$ENDIF ASM_VERSION}
- //[END NewToolbar]
-
- {$ENDIF USE_CONSTRUCTORS}
-
- //================== DateTimePicker =====================//
-
- function WndProcDateTimePickerNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NMhdr: PNMHdr;
- D: TDateTime;
- AllowChg: Boolean;
- NMDTString: PNMDateTimeString;
- begin
- Result := False;
- if Msg.message = WM_NOTIFY then
- begin
- NMHdr := Pointer( Msg.lParam );
- CASE LongInt(NMHdr.code) OF
- DTN_DROPDOWN: if Assigned( Self_.fOnDropDown ) then
- Self_.fOnDropDown( Self_ );
- DTN_CLOSEUP: if Assigned( Self_.fOnCloseUp ) then
- Self_.fOnCloseUp( Self_ );
- DTN_DATETIMECHANGE:
- if Assigned( Self_.fOnChange ) then
- Self_.fOnChange( Self_ );
- DTN_USERSTRING:
- if Assigned( Self_.fOnDTPUserString ) then
- begin
- NMDTString := Pointer( NMHdr );
- D := Self_.DateTime;
- AllowChg := TRUE;
- Self_.fOnDTPUserString( Self_, NMDTString.pszUserString, D, AllowChg );
- NMDTString.dwFlags := Integer( not AllowChg );
- end;
- END;
- end;
- end;
-
- const
- DateTimePickerOptions: array[ TDateTimePickerOption ] of Integer = (
- DTS_TIMEFORMAT, DTS_LONGDATEFORMAT, DTS_UPDOWN, DTS_RIGHTALIGN,
- DTS_SHOWNONE, DTS_APPCANPARSE );
-
- function NewDateTimePicker( AParent: PControl; Options: TDateTimePickerOptions )
- : PControl;
- var Flags: DWORD;
- const
- CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif}CS_PARENTDC or CS_GLOBALCLASS or
- CS_VREDRAW or CS_HREDRAW;
- begin
- DoInitCommonControls( ICC_DATE_CLASSES );
- Flags := MakeFlags( @Options, DateTimePickerOptions );
- Result := _NewCommonControl( AParent, DATETIMEPICK_CLASS,
- (WS_CHILD or WS_VISIBLE or WS_TABSTOP or Flags{$ifdef wince} or WS_BORDER{$endif} {or DTS_APPCANPARSE}),
- TRUE, nil );
- Result.SetSize( 110, 24 );
- Result.AttachProc( WndProcDateTimePickerNotify );
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
-
- procedure TControl.SetDateTime(Value: TDateTime);
- var ST: TSystemTime;
- begin
- if not IsNAN( Value ) then
- DateTime2SystemTime( Value, ST );
- Perform( DTM_SETSYSTEMTIME, Integer( IsNAN( Value ) ) , Integer( @ ST ) );
- end;
-
- function TControl.GetDateTime: TDateTime;
- var ST: TSystemTime;
- begin
- if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ ST ) ) = GDT_VALID then
- SystemTime2DateTime( ST, Result )
- else
- Result := NAN;
- end;
-
- function TControl.Get_SystemTime: TSystemTime;
- begin
- if Perform( DTM_GETSYSTEMTIME, 0, Integer( @ Result ) ) <> GDT_VALID then
- FillChar( Result, Sizeof( Result ), #0 );
- end;
-
- procedure TControl.Set_SystemTime(const Value: TSystemTime);
- begin
- Perform( DTM_SETSYSTEMTIME, Integer( Value.wYear = 0 ) , Integer( @ Value ) );
- end;
-
- function TControl.GetDate: TDateTime;
- begin
- Result := DateTime;
- if not IsNAN( Result ) then
- Result := Trunc( DateTime );
- end;
-
- function TControl.GetTime: TDateTime;
- begin
- Result := DateTime;
- if not IsNAN( Result ) then
- Result := Frac( Result );
- end;
-
- procedure TControl.SetDate(const Value: TDateTime);
- begin
- if IsNAN( Value ) then
- DateTime := Value
- else
- if not IsNAN( DateTime ) then
- DateTime := Trunc( Value ) + Frac( DateTime )
- else
- DateTime := Trunc( Value );
- end;
-
- procedure TControl.SetTime(const Value: TDateTime);
- begin
- if IsNAN( Value ) then
- DateTime := Value
- else
- if not IsNAN( DateTime ) then
- DateTime := Trunc( DateTime ) + Frac( Value )
- else
- DateTime := 1.0 + Frac( Value );
- end;
-
- function TControl.GetDateTimeRange: TDateTimeRange;
- var ST_R: array[ 0..1 ] of TSystemTime;
- begin
- Perform( DTM_GETRANGE, 0, Integer( @ ST_R[ 0 ] ) );
- SystemTime2DateTime( ST_R[ 0 ], Result.FromDate );
- SystemTime2DateTime( ST_R[ 1 ], Result.ToDate );
- end;
-
- procedure TControl.SetDateTimeRange(Value: TDateTimeRange);
- var ST_R: array[ 0..1 ] of TSystemTime;
- begin
- DateTime2SystemTime( Value.FromDate, ST_R[ 0 ] );
- DateTime2SystemTime( Value.ToDate , ST_R[ 1 ] );
- Perform( DTM_SETRANGE,
- Integer( IsNAN( Value.FromDate ) ) or
- (Integer( IsNAN( Value.ToDate ) ) shl 1),
- Integer( @ ST_R[ 0 ] ) );
- end;
-
- function TControl.GetDateTimePickerColor( Index: TDateTimePickerColor): TColor;
- begin
- Result := Perform( DTM_GETMCCOLOR, Integer( Index ), 0 );
- end;
-
- procedure TControl.SetDateTimePickerColor(
- Index: TDateTimePickerColor; Value: TColor);
- begin
- Perform( DTM_SETMCCOLOR, Integer( Index ), Color2RGB( Value ) );
- end;
-
- procedure TControl.SetDateTimeFormat(const Value: KOLString);
- begin
- Perform( DTM_SETFORMAT, 0, Integer( PKOLChar( Value ) ) );
- end;
-
- //===================== RichEdit ========================//
- {$IFNDEF NOT_USE_RICHEDIT}
- type PENLink = ^TENLink;
- TENLink = {$ifndef wince}packed{$endif} record
- hdr: TNMHDR;
- msg: DWORD;
- wParam: Integer;
- lParam: Integer;
- chrg: TCHARRANGE;
- end;
- TEXTRANGEA = {$ifndef wince}packed{$endif} record
- chrg: TCharRange;
- lpstrText: PAnsiChar;
- end;
-
- //[FUNCTION WndProc_RE_LinkNotify]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProc_RE_LinkNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Link: PENLink;
- Range: TextRangeA;
- Buffer: array[ 0..1023 ] of Char;
- begin
- Result := False;
- if (Msg.message = WM_NOTIFY) and (PNMHdr( Msg.lParam ).code = EN_LINK) then
- begin
- Link := Pointer( Msg.lParam );
- Range.chrg := Link.chrg;
- Range.lpstrText := @Buffer[ 0 ];
- Buffer[ 0 ] := #0;
- Self_.Perform( EM_GETTEXTRANGE, 0, Integer( @Range ) );
- if (Buffer[ 1 ] = #0) and (Range.chrg.cpMax - Range.chrg.cpMin > 1) then
- Self_.fREUrl := PWideChar( @ Buffer[ 0 ] )
- else
- Self_.fREUrl := Buffer;
- case Link.msg of
- WM_MOUSEMOVE:
- if assigned( Self_.fOnREOverURL ) then
- Self_.fOnREOverURL( Self_ );
- WM_LBUTTONDOWN, WM_RBUTTONDOWN:
- if assigned( Self_.fOnREUrlClick ) then
- Self_.fOnREUrlClick( Self_ );
- end;
- Rslt := 0;
- Result := TRUE;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProc_RE_LinkNotify]
-
- //[FUNCTION WndProcRichEditNotify]
- {$IFDEF ASM_noVERSION}
- function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- const int_IDC_ARROW = integer( IDC_ARROW );
- asm
- CMP word ptr [EDX].TMsg.message, WM_NOTIFY
- JNE @@chk_WM_DESTROY
- MOV EDX, [EDX].TMsg.lParam
- CMP [EDX].TNMHdr.code, EN_SELCHANGE
- JNE @@ret_false
- CALL TControl.DoSelChange
- JMP @@ret_false
- @@chk_WM_DESTROY:
- CMP word ptr [EDX].TMsg.message, WM_DESTROY
- JNZ @@ret_false
- LEA EAX, [EAX].TControl.fREUrl
- CALL @LStrClr
- @@ret_false:
- XOR EAX, EAX
- RET
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcRichEditNotify( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NMhdr: PNMHdr;
- begin
- Result := False;
- if Msg.message = WM_NOTIFY then
- begin
- NMHdr := Pointer( Msg.lParam );
- case NMHdr.code of
- EN_SELCHANGE:
- begin
- Self_.DoSelChange;
- if Self_.fTransparent then
- Self_.Invalidate;
- end;
- end;
- end
- else
- if Msg.message = WM_DESTROY then
- begin
- Self_.fREURL := '';
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcRichEditNotify]
-
- const RichEditflags: array [ TEditOption ] of Integer = (
- not (es_AutoHScroll or WS_HSCROLL),
- not (es_AutoVScroll or WS_VSCROLL),
- 0 {es_Lowercase - not supported},
- 0 {es_Multiline - RichEdit always multiline},
- es_NoHideSel,
- 0 {es_OemConvert - not suppoted},
- 0 {es_Password - not supported},
- es_Readonly,
- 0 {es_UpperCase - not supported},
- es_WantReturn, 0, es_Number );
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewRichEdit1]
- function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
- begin
- new( Result, CreateRichEdit1( AParent, Options ) );
- end;
- //[END NewRichEdit1]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewRichEdit1]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function NewRichEdit1( AParent: PControl; Options: TEditOptions ): PControl;
- var Flags, I, d, Last, SaveErrMode: Integer;
- label search_richedit;
- begin
- {$IFDEF INPACKAGE}
- Log( '->NewRichEdit1' );
- TRY
- {$ENDIF INPACKAGE}
- if FRichEditModule = 0 then
- begin
- search_richedit:
- I := RichEditIdx;
- Last := High( RichEditLibnames );
- d := 1;
- if RichEditIdx > 0 then
- begin
- I := Last;
- Last := 0;
- d := -1;
- end;
- SaveErrMode := SetErrorMode( SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS );
- while I <> Last + d do
- begin
- FRichEditModule := LoadLibrary( RichEditLibnames[ I ] );
- RichEditClass := RichEditClasses[ I ];
- if FRichEditModule > HINSTANCE_ERROR then break;
- inc( I, d );
- end;
- if FRichEditModule <= HINSTANCE_ERROR then
- FRichEditModule := 0;
- SetErrorMode( SaveErrMode );
- end;
- Flags := MakeFlags( @Options, RichEditFlags );
- {$IFDEF INPACKAGE}
- Log( '//// calling _NewCommonControl' );
- {$ENDIF INPACKAGE}
- Result := _NewCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD
- or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags,
- True, @RichEditActions );
- {$IFDEF INPACKAGE}
- Log( '//// after _NewCommonControl called' );
- {$ENDIF INPACKAGE}
- Result.fIgnoreDefault := TRUE;
- Result.fLookTabKeys := [ tkTab ];
- if eoWantTab in Options then
- Result.fLookTabKeys := [ ];
-
- Result.AttachProc( WndProcRichEditNotify );
- Result.fDoubleBuffered := False;
- Result.fCannotDoubleBuf := True;
- with Result.fBoundsRect do
- begin
- Right := Right + 100;
- Bottom := Top + 200;
- end;
- {$IFDEF INPACKAGE}
- Log( '//// before Perform' );
- {$ENDIF INPACKAGE}
- Result.Perform( EM_SETEVENTMASK, 0,
- ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
- ENM_PROTECTED or $04000000 {ENM_LINK} or ENM_KEYEVENTS );
- {$IFDEF INPACKAGE}
- Log( '//// after Perform' );
- {$ENDIF INPACKAGE}
- Result.fColor := clWindow;
- Result.Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(Result.fColor));
- {$IFDEF RICHEDIT_XPBORDER}
- Result.AttachProc( WndProc_RichEditXPBorder );
- {$ENDIF}
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-NewRichEdit1' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewRichEdit1]
- {$ENDIF NOT_USE_RICHEDIT}
-
- {$ENDIF USE_CONSTRUCTORS}
- {$ifdef win32}
- //[API OleInitialize]
- function OleInitialize(pwReserved: Pointer): HResult; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'ole32.dll' name 'OleInitialize';
- procedure OleUninitialize; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'ole32.dll' name 'OleUninitialize';
-
- //[FUNCTION OleInit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function OleInit: Boolean;
- begin
- if OleInitCount = 0 then
- begin
- Result := False;
- if OleInitialize( nil ) <> 0 then Exit;
- end;
- Inc( OleInitCount );
- Result := True;
- end;
- {$ENDIF ASM_VERSION}
- //[END OleInit]
-
- //[PROCEDURE OleUnInit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure OleUnInit;
- begin
- if OleInitCount > 0 then
- begin
- Dec( OleInitCount );
- if OleInitCount = 0 then
- OleUninitialize;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END OleUnInit]
-
- //[API SysAllocStringLen]
- function SysAllocStringLen(psz: PWideChar; len: Integer): PWideChar; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'oleaut32.dll' name 'SysAllocStringLen';
- procedure SysFreeString( psz: PWideChar ); {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'oleaut32.dll' name 'SysFreeString';
-
- {-}
- //[function StringToOleStr]
- function StringToOleStr(const Source: string): PWideChar;
- var
- SourceLen, ResultLen: Integer;
- Buffer: array[0..1023] of WideChar;
- begin
- SourceLen := Length(Source);
- if Length(Source) < SizeOf(Buffer) div 2 then
- Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
- PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
- else
- begin
- ResultLen := MultiByteToWideChar(0, 0,
- Pointer(Source), SourceLen, nil, 0);
- Result := SysAllocStringLen(nil, ResultLen);
- MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
- Result, ResultLen);
- end;
- end;
- {+}
- {$endif win32}
- {$IFNDEF NOT_USE_RICHEDIT}
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewRichEdit]
- function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
- begin
- new( Result, CreateRichEdit( AParent, Options ) );
- end;
- //[END NewRichEdit]
- {$ELSE not_USE_CONSTRUCTORS}
-
- //[FUNCTION NewRichEdit]
- {$IFDEF ASM_VERSION}
- const RichEdit50W: array[0..11] of Char = ('R','i','c','h','E','d','i','t','5','0','W',#0 );
- function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
- const deltaChr = 24; // sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
- deltaPar = sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
- asm
- PUSHAD
- CALL OleInit
- TEST EAX, EAX
- POPAD
- JZ @@new1
- MOV [RichEditIdx], 0
- CALL NewRichEdit1
- MOV byte ptr [EAX].TControl.fCharFmtDeltaSz, deltaChr
- MOV byte ptr [EAX].TControl.fParaFmtDeltaSz, deltaPar
- RET
- @@new1: CALL NewRichEdit1
- end;
- {$ELSE ASM_VERSION} //Pascal
- function NewRichEdit( AParent: PControl; Options: TEditOptions ): PControl;
- begin
- {$ifdef win32}
- {$IFDEF INPACKAGE}
- Log( '->NewRichEdit' );
- TRY
- {$ENDIF INPACKAGE}
- if OleInit then
- begin
- {$IFDEF INPACKAGE}
- Log( '//// OleInit OK: call NewRichEdit1' );
- {$ENDIF INPACKAGE}
- RichEditIdx := 0;
- Result := NewRichEdit1( AParent, Options );
- Result.fCharFmtDeltaSz := 24; //sizeof( TCharFormat2 ) - sizeof( RichEdit.TCharFormat );
- // sizeof( TCharFormat2 ) is calculated incorrectly
- Result.fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat );
- end
- else
- {$endif win32}
- begin
- {$IFDEF INPACKAGE}
- Log( '//// OleInit failed: call NewRichEdit1' );
- {$ENDIF INPACKAGE}
- Result := NewRichEdit1( AParent, Options );
- end;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-NewRichEdit' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
- //[END NewRichEdit]
-
- {$ENDIF USE_CONSTRUCTORS}
- {$ENDIF NOT_USE_RICHEDIT}
-
- //=====================================================================//
- {$ENDIF WIN_GDI}
-
- { TControl }
-
- //[procedure TControl.Init]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.Init;
- begin
- {$IFDEF _D2orD3}
- inherited; // nothing here for Delphi 4 and higher
- {$ENDIF}
- {$IFDEF USE_GRAPHCTLS}
- fDoInvalidate := InvalidateWindowed;
- {$ENDIF}
- {$IFDEF GDI}
- fOnDynHandlers := WndProcDummy;
- fWndProcKeybd := WndProcDummy;
- fWndProcResizeFlicks := WndProcDummy;
- fPass2DefProc := WndProcDummy;
- fWndFunc := @ WndFunc;
- fCommandActions.aClear := ClearText;
- fWindowed := True;
- fControlClick := DummyObjProc;
- fAutoSize := DummyObjProc;
- fColor := {$ifdef wince}clWindow{$else}clBtnFace{$endif};
- fTextColor := clWindowText;
- {$ENDIF GDI}
- fMargin := 2;
- {$IFDEF GDI}
- fCtl3D := True;
- fCtl3Dchild := True;
- fAlphaBlend := 255;
- {$ENDIF GDI}
- fChildren := NewList;
- {$IFDEF GDI}
- {$ifdef win32}
- fClsStyle := CS_OWNDC;
- fExStyle := WS_EX_CONTROLPARENT;
- {$endif win32}
- fStyle := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_BORDER
- {$ifdef win32} or WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or
- WS_THICKFRAME {$endif};
- {$ENDIF GDI}
- fVisible := True;
- fEnabled := True;
- fDynHandlers := NewList;
- end;
- {$ENDIF ASM_VERSION}
-
- //[PROCEDURE CallTControlInit]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.InitParented( AParent: PControl );
- begin
- Init;
- if AParent <> nil then
- fColor := AParent.fColor;
- Parent := AParent;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.InitParented( AParent: PControl; widget: PGtkWidget;
- need_eventbox: Boolean );
- begin
- Init;
- fHandle := widget;
- fCaptionHandle := fHandle;
- fEventboxHandle := fHandle;
- if need_eventbox then
- begin
- fEventboxHandle := gtk_event_box_new();
- gtk_widget_set_events( fEventboxHandle, GDK_ALL_EVENTS_MASK );
- //gtk_container_add( GTK_CONTAINER( AParent.fHandle ), fEventboxHandle );
- gtk_widget_show( fEventboxHandle );
- gtk_container_add( GTK_CONTAINER( fEventboxHandle ), fHandle );
- end;
- g_object_set_data( G_OBJECT( fEventboxHandle ), ID_SELF, @ Self );
- if AParent <> nil then
- fColor := AParent.fColor;
- Parent := AParent;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //[destructor TControl.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TControl.Destroy;
- var I: Integer;
- F: PControl;
- Ico: HIcon;
- begin
- {$IFDEF USE_CUSTOMEXTENSIONS}
- {$I CUSTOM_TCONTROL_DESTROY.INC}
- {$ENDIF}
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE destroy}
- {$I KOLMHToolTip.pas}
- {$UNDEF destroy}
- {$ENDIF USE_MHTOOLTIP}
- {$IFDEF DEBUG}
- TRY
- F := ParentForm; // or Applet - for form ???
- EXCEPT
- asm
- nop
- end;
- END;
- {$ELSE}
- F := ParentForm; // or Applet - for form ???
- {$ENDIF}
- if F <> nil then
- if F.FCurrentControl = @Self then
- F.FCurrentControl := nil;
-
- if FHandle <> 0 then
- ShowWindow( fHandle, SW_HIDE );
-
- Final;
- {$IFDEF USE_AUTOFREE4CHILDREN}
- {$ELSE}
- DestroyChildren;
- {$ENDIF}
-
- if not fDestroying then
- begin
- fDestroying := True;
-
- if fCtlClsNameChg then
- begin
- FreeMem( fControlClassName );
- fCtlClsNameChg := FALSE;
- end;
-
- {$IFDEF USE_AUTOFREE4CONTROLS}
- {$ELSE}
- fFont.Free;
- fFont := nil;
- fBrush.Free;
- fBrush := nil;
- {$ENDIF}
- fCanvas.Free;
- fCanvas := nil;
-
- if fHandle <> 0 then
- begin
- {$IFNDEF NEW_MENU_ACCELL}
- {$IFDEF USE_AUTOFREE4CONTROLS}
- {$ELSE}
- if fAccelTable <> 0 then
- begin
- DestroyAcceleratorTable( fAccelTable );
- fAccelTable := 0;
- end;
- {$ENDIF}
- {$ENDIF}
- {$IFDEF USE_AUTOFREE4CONTROLS}
- {$ELSE}
- fMenuObj.Free;
- while fImageList <> nil do
- fImageList.Free;
- {$ENDIF}
- I := fHandle;
- Ico := fIcon;
- if (Ico <> 0) and (Ico <> HIcon(-1)) then
- if not fIconShared then
- DestroyIcon( Ico );
- if IsWindow( I ) then
- begin
- // RemoveProp( I, ID_SELF ); //************** Remarked By M.Gerasimov
- if not fNCDestroyed then
- begin
- {$IFDEF DEBUG_ENDSESSION}
- if EndSession_Initiated then
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'DESTROYING HWND:' + Int2Str( I ) );
- {$ENDIF}
- //if fIsForm then
- {$IFDEF USE_PROP}
- SetProp( I, ID_SELF, 0 );
- {$ELSE}
- SetWindowLong( I, GWL_USERDATA, 0 );
- {$ENDIF}
- DestroyWindow( I );
- end;
- end;
- fHandle := 0;
- end;
-
- if fCustomData <> nil then
- FreeMem( fCustomData );
- fCustomData := nil;
- fCustomObj.Free;
- fCustomObj := nil;
-
- if fTmpBrush <> 0 then
- DeleteObject( fTmpBrush );
- fTmpBrush := 0;
-
- //if FCaption <> nil then FreeMem( FCaption );
- fCaption := '';
- if fStatusTxt <> nil then
- FreeMem( fStatusTxt );
-
- if fParent <> nil then
- begin
- fParent.fChildren.Remove( @Self );
- {$IFDEF USE_AUTOFREE4CHILDREN}
- fParent.RemoveFromAutoFree( @ Self );
- {$ENDIF}
- if fParent.fCurrentControl = @Self then
- fParent.fCurrentControl := nil;
- end;
-
- fChildren.Free;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- {$ELSE}
- fTBttCmd.Free;
- fTBttTxt.Free;
- fTmpFont.Free;
- {$ENDIF}
- fDynHandlers.Free;
- //fREUrl := '';
- inherited;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE code}
- {$I KOLMHToolTip.pas}
- {$UNDEF code}
- {$ENDIF}
-
- //[procedure TControl.SetEnabled]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetEnabled( Value: Boolean );
- begin
- if GetEnabled = Value then Exit;
- fEnabled := Value;
- if Value then
- fStyle := fStyle and not WS_DISABLED
- else
- fStyle := fStyle or WS_DISABLED;
- if fHandle <> 0 then
- EnableWindow( fHandle, fEnabled );
- Invalidate; // necessary for Graphic controls
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetParentWindow]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetParentWindow: HWnd;
- begin
- Result := 0;
- if fParent = nil then Exit;
- Result := fParent.GetWindowHandle;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetWindowHandle: HWnd;
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.GetWindowHandle' );
- TRY
- {$ENDIF INPACKAGE}
- if fHandle = 0 then
- begin
- if not fCreateVisible then
- begin
- Set_Visible( False );
- CreateWindow; //virtual!!!
- fCreateHidden := True;
- end
- else
- CreateWindow; //virtual!!!
- end;
- Result := fHandle;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.GetWindowHandle' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
- {-}
-
- {$IFDEF _D7orHigher}
- // may be it was a good idea to replace CreateWindowEx,
- // but Inprise forget about {$ifdef wince}cdecl{$else}stdcall{$endif}... In result, asm-version became broken.
- //[API CreateWindowEx]
- {$IFNDEF UNICODE_CTRLS}
- function CreateWindowEx(dwExStyle: DWORD; lpClassName: PChar;
- lpWindowName: PChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer;
- hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND;
- {$ifdef wince}cdecl{$else}stdcall{$endif}; external user32 name 'CreateWindowExA';
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF DEBUG_CREATEWINDOW}
- procedure Debug_CreateWindow1( _Self: PControl );
- begin
- {LogFileOutput( GetStartDir + 'Session.log', 'TControl.CreateWindow, ' +
- ' Self = ' + Int2Str( Integer( _Self ) ) +
- ' Caption = ' + _Self.fCaption +
- ' fChildren = ' + Int2Hex( Integer( _Self.fChildren ), 4 ) +
- ' ChildCount = ' + Int2Str( _Self.ChildCount ) );}
- end;
-
- procedure Debug_CreateWindow2( _Self: PControl; const Params: TCreateWndParams );
- begin
- LogFileOutput( GetStartDir + 'Session.log',
- ' ExStyle=' + Int2Hex( Params.ExStyle, 4 ) +
- ' WinClassName=' + Params.WinClassName +
- ' Caption=' + Params.Caption +
- ' Style=' + Int2Hex( Params.Style, 4 ) +
- ' X=' + Int2Str( Params.X ) +
- ' Y=' + Int2Str( Params.Y ) +
- ' Width=' + Int2Str( Params.Width ) +
- ' Height=' + Int2Str( Params.Height ) +
- //' WndParent=' + Int2Str( Params.WndParent ) +
- ' Parent=' + Int2Hex( DWORD( _Self.Parent ), 6 ) +
- ' Menu=' + Int2Str( Params.Menu ) +
- ' hInstance=' + Int2Str( Params.WindowClass.hInstance ) +
- ' Param=' + Int2Str( Integer( Params.Param ) ) +
- ' WindowClass.style:' + Int2Str( Params.WindowClass.style ) +
- ' WindowClass.lpfnWndProc:' + Int2Str( DWORD( Pointer( Params.WindowClass.lpfnWndProc ) ) ) +
- ' WindowClass.cbClsExtra:' + Int2Str( DWORD( Params.WindowClass.cbClsExtra ) ) +
- ' WindowClass.cbWndExtra:' + Int2Str( DWORD( Params.WindowClass.cbWndExtra ) ) +
- ' WindowClass.hInstance:' + Int2Str( Params.WindowClass.hInstance ) +
- ' WindowClass.hIcon:' + Int2Str( Params.WindowClass.hIcon ) +
- ' WindowClass.hCursor:' + Int2Str( Params.WindowClass.hCursor ) +
- ' WindowClass.hbrBackground:' + Int2Str( Params.WindowClass.hbrBackground ) +
- ' WindowClass.lpszMenuName:' + Params.WindowClass.lpszMenuName +
- ' WindowClass.lpszClassName:' + Params.WindowClass.lpszClassName
- );
- end;
- {$ENDIF DEBUG_CREATEWINDOW}
-
- {+}
- //[function TControl.CreateWindow]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.CreateWindow: Boolean;
- const
- CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif} CS_PARENTDC or CS_GLOBALCLASS;
- CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
- var TempClass: TWndClass;
- Params: TCreateWndParams;
- ClassRegistered: Boolean;
- {$IFDEF _FPC}
- SClassName: String;
- {$ENDIF ASM_VERSION}
- {$ifdef wince}
- DR: TRect;
- mbi: SHMENUBARINFO;
- {$endif wince}
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.CreateWindow' );
- TRY
- {$ENDIF INPACKAGE}
- {$IFDEF DEBUG_CREATEWINDOW}
- Debug_CreateWindow1( @ Self );
- {$ENDIF DEBUG_CREATEWINDOW}
- Result := False;
- if fParent <> nil then
- if fParent.GetWindowHandle = 0 then
- Exit;
- if fHandle <> 0 then
- begin
- if fCreateHidden then
- begin
- CreateChildWindows;
- Set_Visible( True );
- fCreateHidden := False;
- end
- else
- begin
- CreateChildWindows;
- end;
- Result := True;
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit;
- end;
-
- {$IFDEF USE_GRAPHCTLS}
- if not fWindowed then Exit;
- {$ENDIF}
-
- {$IFDEF INPACKAGE}
- Log( '/// Filling Params' );
- {$ENDIF INPACKAGE}
-
- FillChar( Params, Sizeof( Params ), 0 );
- {$ifndef wince}
- Params.WindowClass.hCursor := LoadCursor( 0, IDC_ARROW );
- {$endif wince}
- Params.WindowClass.hInstance := hInstance;
- Params.WindowClass.lpfnWndProc := fDefWndProc;
- Params.WindowClass.style := fClsStyle;
- {$IFDEF _FPC}
- SClassName := SubClassName;
- StrCopy( Params.WinClsNamBuf, @ SClassName[ 1 ] );
- {$ELSE}
- {$IFNDEF UNICODE_CTRLS}
- StrCopy( Params.WinClsNamBuf, @ SubClassName[ 1 ] );
- {$ELSE}
- WStrCopy(Params.WinClsNamBuf, @SubClassName[1]);
- {$ENDIF}
- {$ENDIF}
- Params.Param := nil;
- Params.Inst := hInstance;
- Params.Menu := fMenu;
- Params.WndParent := GetParentWnd( TRUE );
- Params.Height := fBoundsRect.Bottom - fBoundsRect.Top;
- if Params.Height = 0 then
- Params.Height := CW_UseDefault;
- Params.Width := fBoundsRect.Right - fBoundsRect.Left;
- if Params.Width = 0 then
- Params.Width := CW_UseDefault;
- Params.Y := fBoundsRect.Top;
- Params.X := fBoundsRect.Left;
- if not fIsControl and (fChangedPosSz and 3 = 0) then
- begin
- Params.Y := CW_UseDefault;
- Params.X := CW_UseDefault;
- end;
- {$ifdef wince}
- if fIsForm then begin
- SystemParametersInfo(SPI_GETWORKAREA, 0, @DR, 0);
- if Params.X = Integer(CW_UseDefault) then
- Params.X:=DR.Left;
- if Params.Y = Integer(CW_UseDefault) then
- Params.Y:=DR.Top;
- if Params.Width = Integer(CW_UseDefault) then
- Params.Width:=DR.Right - Params.X;
- if Params.Height = Integer(CW_UseDefault) then
- Params.Height:=ScreenHeight - Params.Y;
- end;
- {$endif wince}
- Params.Style := fStyle;
- Params.Caption := PKOLChar( fCaption );
- Params.WinClassName := @ Params.WinClsNamBuf[ 0 ];
- Params.ExStyle := fExStyle;
-
- {$IFDEF INPACKAGE}
- Log( '/// Getting class info' );
- {$ENDIF INPACKAGE}
- {$ifndef wince}
- if fControlClassName <> nil then
- begin
- GetClassInfo( Params.Inst,fControlClassName,Params.WindowClass );
- Params.WindowClass.hInstance := Params.Inst;
- Params.WindowClass.style := Params.WindowClass.style and
- not CS_OFF or CS_ON;
- end;
- {$endif wince}
- if (fDefWndProc = nil) {$ifdef wince} and GetClassInfo(Params.Inst,fControlClassName,Params.WindowClass)
- and (ptruint(@Params.WindowClass.lpfnWndProc) and $FFFFFF <> ptruint(@WndFunc)) {$endif}
- then
- fDefWndProc := {$ifdef FPC}@{$endif}Params.WindowClass.lpfnWndProc;
- if Params.WndParent = 0 then
- if Params.Style and WS_CHILD <> 0 then Exit;
-
- ClassRegistered := GetClassInfo( Params.Inst,Params.WinClassName, TempClass );
- {$IFDEF INPACKAGE}
- Log( '/// Registering window class' );
- {$ENDIF INPACKAGE}
- if not ClassRegistered then
- begin
- Params.WindowClass.lpszClassName := Params.WinClassName;
- Params.WindowClass.lpfnWndProc := @ WndFunc;
- if RegisterClass( Params.WindowClass ) = 0 then Exit;
- end;
-
- {$IFDEF DEBUG_CREATEWINDOW}
- Debug_CreateWindow2( @ Self, Params );
- {$ENDIF}
- {$ifdef wince}
- if fDefWndProc = nil then
- {$endif wince}
- CreatingWindow := @Self;
- {$IFDEF INPACKAGE}
- Log( '/// Calling CreateWindowEx' );
- {$ENDIF INPACKAGE}
- {$IFNDEF UNICODE_CTRLS}
- fHandle := CreateWindowEx( Params.ExStyle, Params.WinClassName,
- Params.Caption, Params.Style, Params.X, Params.Y,
- Params.Width, Params.Height, Params.WndParent,
- Params.Menu, Params.Inst,
- Params.Param );
- {$ELSE}
- fHandle := CreateWindowExW( Params.ExStyle{ or WS_EX_RTLREADING}, Params.WinClassName,
- Params.Caption, Params.Style, Params.X, Params.Y,
- Params.Width, Params.Height, Params.WndParent,
- Params.Menu, Params.Inst,
- Params.Param );
-
- {$ENDIF}
- {$IFDEF INPACKAGE}
- Log( '/// CreateWindowEx called' );
- {$ENDIF INPACKAGE}
-
- {$ifdef wince}
- if fDefWndProc <> nil then
- SetWindowLong(fHandle, GWL_WNDPROC, LongInt(@WndFunc));
- if not fIsControl then
- if fMenuObj <> nil then
- CeSetMenu(fHandle, PMenu(fMenuObj))
- else
- if CePlatform <> cpSmartphone then begin
- FillChar(mbi, SizeOf(mbi), 0);
- with mbi do begin
- cbSize:=SizeOf(mbi);
- hwndParent:=fHandle;
- dwFlags:=SHCMBF_EMPTYBAR;
- end;
- if SHCreateMenuBar(@mbi) then begin
- GetWindowRect(mbi.hwndMB, DR);
- if Params.Y + Params.Height > DR.Top then
- SetWindowPos(fHandle, 0, 0, 0, Params.Width, DR.Top - Params.Y, SWP_NOZORDER or SWP_NOREPOSITION or SWP_NOMOVE);
- end;
- end;
- if fStyle and WS_VISIBLE <> 0 then
- Perform(WM_SHOWWINDOW, 1, 0);
- {$endif wince}
-
- {$IFDEF DEBUG_CREATEWINDOW}
- if fHandle = 0 then
- begin
- MessageBox(0,
- PKOLChar(SysErrorMessage(GetLastError)),
- 'Error creating window',mb_iconhand);
- Exit;
- end;
- {$ENDIF}
- {$IFDEF INPACKAGE}
- Log( '/// SendMessage WM_UPDATEUISTATE' );
- {$ENDIF INPACKAGE}
- {$ifndef wince}
- SendMessage( fHandle, $0128 {WM_UPDATEUISTATE},
- 2 {UIS_CLEAR} or (1 {UISF_HIDEFOCUS} shl 16),0);
- {$endif wince}
- {$IFDEF USE_PROP}
- if GetProp(FHandle,ID_SELF) = 0 then
- begin
- CreatingWindow := nil;
- SetProp(FHandle, ID_SELF, THandle(@Self));
- end;
- {$ELSE}
- CreatingWindow := nil;
- SetWindowLong( FHandle, GWL_USERDATA, Integer(@Self) );
- {$ENDIF}
- //***
- {$IFDEF INPACKAGE}
- Log( '/// Perform WM_SETICON' );
- {$ENDIF INPACKAGE}
- {$IFDEF SMALLEST_CODE}
- {$ELSE}
- {$ifndef wince}
- if not fIsControl then
- Perform( WM_SETICON, 1 {ICON_BIG}, GetIcon );
- {$endif wince}
- {$ENDIF}
- if Assigned( FCreateWndExt ) then
- FCreateWndExt( @Self );
- {$IFDEF INPACKAGE}
- Log( '/// ApplyFont2Wnd' );
- {$ENDIF INPACKAGE}
- ApplyFont2Wnd;
-
- {$IFDEF INPACKAGE}
- Log( '/// CreateChildWindows' );
- {$ENDIF INPACKAGE}
-
- CreateChildWindows;
-
- {$IFDEF INPACKAGE}
- Log( '/// CreateChildWindows called OK' );
- {$ENDIF INPACKAGE}
-
- Result := True;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.CreateWindow' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF}
- {$ENDIF WIN_GDI}
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.VisualizyWindow;
- var i: Integer;
- C: PControl;
- begin
- if fHandle = nil then Exit;
- if not fIsApplet and FVisible then
- begin
- for i := 0 to ChildCount-1 do
- begin
- C := Children[ i ];
- if C.fVisible then
- C.VisualizyWindow;
- end;
- gtk_widget_show( fHandle );
- end;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //-
- //[procedure TControl.CreateSubclass]
- procedure TControl.CreateSubclass(var Params: TCreateParams;
- ControlClassName: PKOLChar);
- const
- CS_OFF = {$ifdef win32}CS_OWNDC or CS_CLASSDC or {$endif} CS_PARENTDC or CS_GLOBALCLASS;
- CS_ON = 0; //CS_VREDRAW or CS_HREDRAW;
- var
- SaveInstance: THandle;
- begin
- if fControlClassName <> nil then
- with Params do
- begin
- SaveInstance := WindowClass.hInstance;
- // {$IFNDEF UNICODE_CTRLS}
- if not GetClassInfo(HInstance, fControlClassName, WindowClass) and
- not GetClassInfo(0, fControlClassName, WindowClass)
- then
- GetClassInfo(WindowClass.hInstance, fControlClassName, WindowClass);
- // {$ELSE}
- // if not GetClassInfoW(HInstance, pWideChar(fControlClassName), WindowClass) and
- // not GetClassInfoW(0, pWidechar(fControlClassName), WindowClass)
- // then
- // GetClassInfoW(WindowClass.hInstance, pWideChar(fControlClassName), WindowClass);
- // {$ENDIF}
- WindowClass.hInstance := SaveInstance;
- WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
- end;
- end;
-
- //[FUNCTION WndProcMouse]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcMouse(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- var MouseData: TMouseEventData;
- begin
- Result := False;
- if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= $20A {WM_MOUSELAST}) then
- with MouseData do
- begin
- Shift := Msg.wParam;
- if GetKeyState( VK_MENU ) < 0 then
- Shift := Shift or MK_ALT;
- X := LoWord( Msg.lParam );
- Y := HiWord( Msg.lParam );
- //Button := TMouseButton(Msg.wParam);
- // not possible: wParam can contain a combination of flags
- // MK_CONTROL, MK_LBUTTON, MK_RBUTTON, MK_MBUTTON, MK_SHIFT, MK_XBUTTON1, MK_XBUTTON2
- // So, Shift must be tested.
- Button := mbNone;
-
- StopHandling := FALSE;
- Rslt := 0; // needed ?
- case Msg.message of
- WM_LBUTTONDOWN:
- if Assigned( Self_.OnMouseDown ) then
- begin
- Button := mbLeft;
- Self_.OnMouseDown( Self_, MouseData );
- end;
- WM_RBUTTONDOWN:
- if Assigned( Self_.OnMouseDown ) then
- begin
- Button := mbRight;
- Self_.OnMouseDown( Self_, MouseData );
- end;
- WM_MBUTTONDOWN:
- if Assigned( Self_.OnMouseDown ) then
- begin
- Button := mbMiddle;
- Self_.OnMouseDown( Self_, MouseData );
- end;
- WM_LBUTTONUP:
- if Assigned( Self_.OnMouseUp ) then
- begin
- Button := mbLeft;
- Self_.OnMouseUp( Self_, MouseData );
- end;
- WM_RBUTTONUP:
- if Assigned( Self_.OnMouseUp ) then
- begin
- Button := mbRight;
- Self_.OnMouseUp( Self_, MouseData );
- end;
- WM_MBUTTONUP:
- if Assigned( Self_.OnMouseUp ) then
- begin
- Button := mbMiddle;
- Self_.OnMouseUp( Self_, MouseData );
- end;
- WM_MOUSEMOVE:
- if Assigned( Self_.OnMouseMove ) then
- Self_.OnMouseMove( Self_, MouseData );
- WM_LBUTTONDBLCLK:
- if Assigned( Self_.OnMouseDblClk ) then
- begin
- Button := mbLeft;
- Self_.OnMouseDblClk( Self_, MouseData );
- end;
- WM_RBUTTONDBLCLK:
- if Assigned( Self_.OnMouseDblClk ) then
- begin
- Button := mbRight;
- Self_.OnMouseDblClk( Self_, MouseData );
- end;
- WM_MBUTTONDBLCLK:
- if Assigned( Self_.OnMouseDblClk ) then
- begin
- Button := mbMiddle;
- Self_.OnMouseDblClk( Self_, MouseData );
- end;
- $020A {WM_MOUSEWHEEL}:
- if Assigned( Self_.OnMouseWheel ) then
- Self_.OnMouseWheel( Self_, MouseData );
- else
- Exit; //Result := False;
- end;
- Result := StopHandling;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcMous]
-
- //[FUNCTION WndProcKeybd]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcKeybd(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- var C : KOLChar;
- begin
- Result := True;
- case Msg.message of
- WM_KEYDOWN, WM_SYSKEYDOWN:
- if assigned( Self_.fOnKeyDown ) then
- Self_.fOnKeyDown( Self_, Msg.wParam, GetShiftState );
- WM_KEYUP, WM_SYSKEYUP:
- if assigned( Self_.fOnKeyUp ) then
- Self_.fOnKeyUp( Self_, Msg.wParam, GetShiftState );
- WM_CHAR, WM_SYSCHAR:
- if assigned( Self_.fOnChar ) then
- begin
- C := KOLChar( Msg.wParam );
- Self_.fOnChar( Self_, C, GetShiftState );
- Msg.wParam := Integer( C );
- end;
- {$IFDEF SUPPORT_ONDEADCHAR}
- WM_DEADCHAR, WM_SYSDEADCHAR:
- if assigned( Self_.fOnDeadChar ) then
- begin
- C := KOLChar( Msg.wParam );
- Self_.fOnDeadChar( Self_, C, GetShiftState );
- Msg.wParam := Integer( C );
- end;
- {$ENDIF SUPPORT_ONDEADCHAR}
- else begin
- Result := False;
- Exit;
- end;
- end;
- if Msg.wParam <> 0 then
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcKeybd]
-
- //[function WndProcDummy]
- function WndProcDummy(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- begin
- Result := False;
- end;
-
- const
- MM_MCINOTIFY = $3B9;
-
- function WndProcOnClose( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var Accept: Boolean;
- begin
- Result := FALSE;
- if Msg.message = WM_CLOSE then
- begin
- {$IFDEF NEW_MODAL}
- // version of code by Alexander Pravdin
- begin
- Accept := True;
- if Assigned( Sender.fOnClose ) then begin
- Sender.fOnClose( Sender, Accept );
- if AppletRunning then
- if Accept then
- if Sender.fModal > 0 then begin
- if Sender.ModalResult = 0 then
- Sender.fModalResult := Integer($80000000);
- Msg.message := 0;
- Exit;
- end
- else
- Sender.fOnClose := nil
- else begin
- Rslt := 0;
- Sender.fModalResult := 0;
- Result := TRUE;
- end
- else
- Sender.fOnClose := nil;
- end
- else begin
- if Sender.fModal > 0 then begin
- if Sender.ModalResult = 0 then
- Sender.fModalResult := Integer($80000000);
- Exit;
- end;
- end;
-
- if Accept then begin
- if Sender.IsMainWindow or ( Applet = Sender ) then
- begin
- {if Assigned( Applet ) and ( Applet <> Sender ) then
- Applet.Perform( WM_CLOSE, 0, 0 );}
- PostQuitMessage( 0 );
- Rslt := 0;
- end
- else
- Exit; // Default;
- end;
- end;
- {$ELSE}
- begin
- Accept := True;
- if Assigned( Sender.fOnClose ) then
- begin
- Sender.fOnClose( Sender, Accept );
- if (not Accept) and (AppletRunning) then
- begin
- Rslt := 0;
- Result := TRUE;
- end
- else //+-+
- Sender.fOnClose := nil;
- end;
- if Accept then
- begin
- if Sender.IsMainWindow or (Applet = Sender) then
- begin
- {if Assigned( Applet ) and (Applet <> Sender) then
- Applet.Perform( WM_CLOSE, 0, 0 );}
- PostQuitMessage( 0 );
- Rslt := 0;
- end
- else
- Exit; //Default;
- end;
- end;
- {$ENDIF}
- end;
- end;
-
- procedure TControl.SetOnClose(const AOnClose: TOnEventAccept);
- begin
- fOnClose := AOnClose;
- AttachProc( WndProcOnClose );
- end;
-
- function WndProcFormOnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) or
- (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_RBUTTONDBLCLK) or
- (Msg.message = WM_MBUTTONDOWN) or (Msg.message = WM_MBUTTONDBLCLK)
- then
- begin
- Sender.fRightClick := (Msg.message = WM_RBUTTONDOWN) or
- (Msg.message = WM_RBUTTONDBLCLK);
- if Assigned( Sender.fOnClick ) then
- Sender.fOnClick( Sender );
- end;
- end;
-
- procedure TControl.SetFormOnClick(const AOnClick: TOnEvent);
- begin
- fOnClick := AOnClick;
- AttachProc( WndProcFormOnClick );
- end;
-
-
- {$IFDEF ASM_VERSION}//------------------
-
- {$DEFINE ASM_LOCAL}
- {$IFDEF NEW_MODAL}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
-
- {$ELSE}//-------------------------------
-
- {$IFDEF ASM_LOCAL}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
-
- {$ENDIF}//------------------------------
-
- {$IFDEF USE_GRAPHCTLS}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
-
- //[function TControl.WndProc]
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_LOCAL} //Pascal
-
- {$IFDEF DEBUG_CREATEWINDOW}
- var DbgCWCount: Integer = 0;
- {$ENDIF DEBUG_CREATEWINDOW}
- function TControl.WndProc( var Msg: TMsg ): Integer;
- var C : PControl;
- F: HWnd;
- PassFun: function( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
-
- procedure Default;
- begin
- Result := CallDefWndProc( Msg );
- end;
-
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.WndProc' );
- TRY
- {$ENDIF INPACKAGE}
- {$IFDEF DEBUG_CREATEWINDOW}
- Inc( DbgCWCount );
- if DbgCWCount < 10 then
- LogFileOutput( GetStartDir + 'Session.log', 'TControl.WndProc: ' +
- ' Msg.hwnd=' + Int2Str( Msg.hwnd ) +
- ' Msg.message=' + Int2Hex( Msg.message, 2 ) +
- ' Msg.wParam=' + Int2Str( Msg.wParam ) + '=$' + Int2Hex( Msg.wParam, 4 ) +
- ' Msg.lParam=' + Int2Str( Msg.lParam ) + '=$' + Int2Hex( Msg.lParam, 4 ) );
- {$ENDIF DEBUG_CREATEWINDOW}
- if (Msg.hwnd <> 0) and (fHandle = 0)
- {$IFDEF USE_GRAPHCTLS} and fWindowed {$ENDIF} then
- fHandle := Msg.hwnd;
-
- {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
- PassFun := fPass2DefProc;
- {$IFDEF DEBUG_MCK} mck_Log( '01' ); {$ENDIF}
- if not (AppletRunning and (Applet <> @Self) and Assigned( Applet ) and
- Assigned( Applet.OnMessage ) and Applet.OnMessage( Msg, Result )) then
- begin {$IFDEF DEBUG_MCK} mck_Log( '02' ); {$ENDIF}
- if not (Assigned( OnMessage ) and OnMessage( Msg, Result )) then
- begin {$IFDEF DEBUG_MCK} mck_Log( '03' ); {$ENDIF}
- if not fOnDynHandlers( @Self, Msg, Result ) then
- begin {$IFDEF DEBUG_MCK} mck_Log( '04' ); {$ENDIF}
- if not fWndProcResizeFlicks( @Self, Msg, Result ) then
- begin {$IFDEF DEBUG_MCK} mck_Log( '05' ); {$ENDIF}
- case Msg.message of
- WM_CLOSE:
- begin // handler by default - simple:
- if (Applet = @ Self) or IsMainWindow then begin
- PostQuitMessage( 0 );
- {$ifdef wince}
- Result:=0;
- exit;
- {$endif wince}
- end;
- Default;
- end;
- {$IFDEF USE_PROP}
- WM_NCDESTROY:
- begin
- RemoveProp( fHandle, ID_SELF ); //********* Added By M.Gerasimov
- end;
- {$ENDIF}
- WM_DESTROY:
- begin
- fBeginDestroying := TRUE;
- Default;
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit;
- end;
- {$ifdef wince}
- WM_WINDOWPOSCHANGED:
- begin
- Default;
- { In case of subclassing, DefWindowProc must be called on wince
- to generate WM_SIZE and WM_MOVE messages }
- if fDefWndProc <> nil then
- Result:=DefWindowProc(Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam);
- exit;
- end;
- {$endif wince}
- WM_SIZE: begin
- {$IFDEF INPACKAGE}
- Log( 'WM_SIZE >>> Default' );
- {$ENDIF INPACKAGE}
- Default;
- {$IFDEF INPACKAGE}
- Log( '//// Default called' );
- {$ENDIF INPACKAGE}
- fWindowState := TWindowState( Msg.wParam );
- {$IFDEF OLD_ALIGN}
- if not fIsForm then
- Global_Align( fParent );
- {$ENDIF}
- {$IFDEF INPACKAGE}
- Log( '//// Before Global_Align' );
- {$ENDIF INPACKAGE}
- Global_Align( @Self );
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit;
- end;
- {$ifndef wince}
- WM_SysCommand:
- begin
- if ((Msg.wParam and $FFF0) = SC_MINIMIZE) and
- IsMainWindow and (@Self <> Applet) then
- begin
- PostMessage( Applet.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0 );
- Result := 0;
- end
- else Default;
- end;
- {$endif wince}
- WM_SETFOCUS:
- begin
- if not DoSetFocus then
- begin
- Result := 0;
- end
- else
- begin
- Inc( fClickDisabled );
- Default;
- Dec( fClickDisabled );
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit;
- end;
- end;
- WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
- begin
- Result := SendMessage(Msg.LParam, CN_BASE + Msg.message, Msg.WParam, Msg.LParam);
- end;
- WM_COMMAND:
- begin
- {$IFDEF USE_PROP}
- C := Pointer( GetProp( Msg.lParam, ID_SELF ) );
- {$ELSE}
- C := Pointer( GetWindowLong( Msg.lParam, GWL_USERDATA ) );
- {$ENDIF}
- if C <> nil then
- begin
- Result := SendMessage( Msg.lParam, CM_COMMAND, Msg.wParam, Msg.lParam );
- end
- else Default;
- end;
- WM_KEYFIRST..WM_KEYLAST:
- begin
- F := GetFocus;
- if (F <> fFocusHandle) and (F <> fHandle)
- {$IFDEF USE_GRAPHCTLS} and fWindowed {$ENDIF}
- {$IFDEF KEY_PREVIEW}
- and not (fKeyPreviewing (*and
- ((Msg.Message=WM_KEYDOWN) {or (Msg.message = WM_CHAR) )*))
- {$ENDIF}
- then
- begin
- Result := 0;
- // Jump to PassFun here. Prevents beep in case when WM_KEYDOWN
- // called another form and focus is changed, so WM_KEYUP failed
- // to handle.
- end
- else
- begin
- {$IFDEF KEY_PREVIEW}
- fkeypreviewing:=false; //ADDITION JUST FOR CORRECT KEYPREVIEWING
- {$ENDIF}
- if fGlobalProcKeybd( @Self, Msg, Result ) then
- begin
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit; //??????????????????
- end;
- if fWndProcKeybd( @Self, Msg, Result ) then
- begin
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit; //???????????????????
- end;
- if ((GetKeystate( VK_CONTROL ) or GetKeyState( VK_MENU )) >= 0) then
- begin
- //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- if (Msg.message <> WM_CHAR) // v1.02 Tabulate AND " in EditBox fix
- //+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- then
- begin
- C := ParentForm;
- if (C <> nil) and Assigned(C.fGotoControl) and
- C.fGotoControl( @Self, Msg.wParam,
- (Msg.message <> WM_KEYDOWN) and
- (Msg.message <> WM_SYSKEYDOWN) ) then
- begin
- Msg.wParam := 0;
- Result := 0;
- end
- else Default;
- end
- //+++++++++++++++++++++++++++++++++++++++++++++//
- else //
- if Msg.wParam = 9 then // prevent system beep //
- begin //
- Msg.wParam := 0; //
- Result := 0; //
- end //
- //+++++++++++++++++++++++++++++++++++++++++++++//
- else Default;
- end
- else Default;
- end;
- end;
- else begin
- {$IFDEF DEBUG_MCK} mck_Log( 'else' ); {$ENDIF}
- Default; //+-+
- {$IFDEF INPACKAGE}
- LogOK;
- {$ENDIF INPACKAGE}
- Exit; //+-+
- end;
- end;
- end;
- end;
- end;
- end;
- {$IFDEF DEBUG_MCK} mck_Log( '06' ); {$ENDIF}
- if not AppletTerminated and not fNCDestroyed then
- begin {$IFDEF DEBUG_MCK} mck_Log( '07' ); {$ENDIF}
- PassFun( @Self, Msg, Result ); //+-+
- {$IFDEF DEBUG_MCK} mck_Log( '08' ); {$ENDIF}
- end;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.WndProc' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_LOCAL}
- //[END TContro]
-
- {$UNDEF ASM_LOCAL}
-
- {$ENDIF WIN_GDI}
- //[procedure SetMouseEvent]
- {$IFDEF GDI}
- procedure SetMouseEvent( Self_: PControl );
- begin
- Self_.AttachProc( WndProcMouse );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function mouse_events_handler( Obj: PGtkWidget; var Event: TGdkEventAny ): Boolean; cdecl;
- var Sender: PControl;
- M: TMouseEventData;
- procedure PrepareMouseEvent( const Evt: TGdkEventMotion );
- begin
- M.Button := mbNone;
- if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Button := mbLeft
- else
- if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Button := mbRight
- else
- if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Button := mbMiddle;
- M.Shift := 0;
- if Evt.state and GDK_SHIFT_MASK <> 0 then M.Shift := MK_SHIFT;
- if Evt.state and GDK_CONTROL_MASK <> 0 then M.Shift := M.Shift or MK_CONTROL;
- if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
- if Evt.state and GDK_BUTTON1_MASK <> 0 then M.Shift := M.Shift or MK_LBUTTON;
- if Evt.state and GDK_BUTTON2_MASK <> 0 then M.Shift := M.Shift or MK_RBUTTON;
- if Evt.state and GDK_BUTTON3_MASK <> 0 then M.Shift := M.Shift or MK_MBUTTON;
- if Evt.state and GDK_LOCK_MASK <> 0 then M.Shift := M.Shift or MK_LOCK;
- M.X := Round( Evt.x );
- M.Y := Round( Evt.y );
- end;
- var scrl: PGdkEventScroll;
- z: SmallInt;
- begin
- Result := FALSE;
- //Sender := Pointer( Event.window );
- Sender := g_object_get_data( G_OBJECT( Obj ), ID_SELF );
- CASE Event._type OF
- GDK_MOTION_NOTIFY,
- GDK_BUTTON_PRESS,
- GDK_2BUTTON_PRESS,
- GDK_3BUTTON_PRESS, // òðîéíîé êëèê ìûøè - ñ÷èòàòü êàê äâîéíîé?
- GDK_BUTTON_RELEASE,
- GDK_SCROLL: ;
- else Exit;
- END;
- PrepareMouseEvent( PGdkEventMotion( @ Event )^ );
- CASE Event._type OF
- GDK_MOTION_NOTIFY :
- begin
- if Assigned( Sender.fOnMouseMove ) then
- begin
- Sender.fOnMouseMove( Sender, M );
- Result := TRUE;
- end;
- end;
- GDK_BUTTON_PRESS :
- begin
- if Assigned( Sender.fOnMouseDown ) then
- begin
- Sender.fOnMouseDown( Sender, M );
- Result := TRUE;
- end;
- end;
- GDK_2BUTTON_PRESS,
- GDK_3BUTTON_PRESS :
- begin
- if Assigned( Sender.fOnMouseDblClk ) then
- begin
- Sender.f3ButtonPress := Event._type = GDK_3BUTTON_PRESS;
- Sender.fOnMouseDblClk( Sender, M );
- Result := TRUE;
- end;
- end;
- GDK_BUTTON_RELEASE :
- begin
- if Assigned( Sender.fOnMouseUp ) then
- begin
- Sender.fOnMouseUp( Sender, M );
- Result := TRUE;
- end;
- if Assigned( Sender.fOnClick ) then
- Sender.fOnClick( Sender );
- end;
- GDK_SCROLL :
- begin
- if Assigned( Sender.fOnMouseWheel ) then
- begin
- scrl := @ Event;
- if scrl.direction = GDK_SCROLL_UP then
- z := 120
- else if scrl.direction = GDK_SCROLL_DOWN then
- z := -120 //todo: direction and value?
- else
- z := 0;
- M.Shift := M.Shift or DWord(z shl 16);
- Sender.fOnMouseWheel( Sender, M );
- Result := TRUE;
- end;
- end;
- END;
- end;
-
- procedure SetMouseEvent( Self_: PControl; event_name: PChar );
- begin
- gtk_signal_connect( GTK_OBJECT( Self_.fEventboxHandle ), event_name,
- @mouse_events_handler, Self_ );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.SetOnMouseDown]
- {$IFDEF GDI}
- procedure TControl.SetOnMouseDown(const Value: TOnMouse);
- begin
- fOnMouseDown := Value;
- SetMouseEvent( @Self );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetOnMouseDown(const Value: TOnMouse);
- begin
- fOnMouseDown := Value;
- SetMouseEvent( @Self, 'button_press_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF GDI}
- //[procedure TControl.SetOnMouseMove]
- procedure TControl.SetOnMouseMove(const Value: TOnMouse);
- begin
- fOnMouseMove := Value;
- SetMouseEvent( @Self );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetOnMouseMove(const Value: TOnMouse);
- begin
- fOnMouseMove := Value;
- SetMouseEvent( @Self, 'motion_notify_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.SetOnMouseUp]
- {$IFDEF GDI}
- procedure TControl.SetOnMouseUp(const Value: TOnMouse);
- begin
- fOnMouseUp := Value;
- SetMouseEvent( @Self );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetOnMouseUp(const Value: TOnMouse);
- begin
- fOnMouseUp := Value;
- SetMouseEvent( @Self, 'button_release_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.SetOnMouseDblClk]
- {$IFDEF GDI}
- procedure TControl.SetOnMouseDblClk(const Value: TOnMouse);
- begin
- fOnMouseDblClk := Value;
- SetMouseEvent( @Self );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetOnMouseDblClk(const Value: TOnMouse);
- begin
- fOnMouseDblClk := Value;
- SetMouseEvent( @Self, 'button_press_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.SetOnMouseWheel]
- {$IFDEF GDI}
- procedure TControl.SetOnMouseWheel(const Value: TOnMouse);
- begin
- fOnMouseWheel := Value;
- SetMouseEvent( @Self );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetOnMouseWheel(const Value: TOnMouse);
- begin
- fOnMouseWheel := Value;
- SetMouseEvent( @Self, 'scroll_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
-
- {$IFDEF WIN_GDI}
- //[procedure TControl.SetClsStyle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetClsStyle( Value: DWord );
- begin
- if fClsStyle = Value then Exit;
- fClsStyle := Value;
- if fHandle = 0 then Exit;
- SetClassLong( fHandle, GCL_STYLE, Value );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetStyle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetStyle( Value: DWord );
- begin
- if fStyle = Value then Exit;
- fStyle := Value;
- if fHandle = 0 then Exit;
- SetWindowLong( fHandle, GWL_STYLE, Value );
-
- SetWindowPos( fHandle, 0, 0, 0, 0, 0,
- SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
- SWP_NOZORDER or SWP_FRAMECHANGED );
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- procedure TControl.SetEdgeStyle( Value: TEdgeStyle );
- begin
- if fedgeStyle = Value then Exit;
- fedgeStyle := Value;
- if fHandle = 0 then Exit;
- case Value of
- esRaised:
- begin
- Style := Style and (not SS_SUNKEN);
- ExStyle := ExStyle and (not WS_EX_STATICEDGE);
- ExStyle := ExStyle or WS_EX_WINDOWEDGE;
- Style := Style or WS_DLGFRAME;
- end;
- esLowered:
- begin
- Style := Style and (not WS_DLGFRAME);
- ExStyle := ExStyle or WS_EX_WINDOWEDGE;
- ExStyle := ExStyle or WS_EX_STATICEDGE;
- Style := Style or SS_SUNKEN;
- end;
- else
- Style := Style and (not SS_SUNKEN) and (not WS_DLGFRAME);
- ExStyle := ExStyle and (not WS_EX_STATICEDGE) or WS_EX_WINDOWEDGE;
- end;
-
- Invalidate;
- end;
- {$ENDIF}
-
- //[procedure TControl.SetExStyle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetExStyle( Value: DWord );
- begin
- if fExStyle = Value then Exit;
- fExStyle := Value;
- if fHandle = 0 then Exit;
- SetWindowLong( fHandle, GWL_EXSTYLE, Value );
-
- SetWindowPos( fHandle, 0, 0, 0, 0, 0,
- SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
- SWP_NOZORDER or SWP_FRAMECHANGED );
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
-
- function WndProcSetCursor( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Cur: HCursor;
- begin
- Result := FALSE;
- if Msg.message = WM_SETCURSOR then
- begin
- if (GetCapture = 0) and
- (LOWORD( Msg.lParam ) = HTCLIENT) then
- begin
- if ScreenCursor <> 0 then //YS
- Cur := ScreenCursor //YS
- else //YS
- Cur := Self_.fCursor; //YS
- if Cur <> 0 then //YS
- begin //YS
- Windows.SetCursor( Cur ); //YS
- Rslt := 1; //YS
- Result := TRUE;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetCursor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCursor( Value: HCursor );
- var P: TPoint;
- begin
- AttachProc( WndProcSetCursor );
- if fCursor = Value then Exit;
- fCursor := Value;
- if (fHandle = 0) or (fCursor = 0) then Exit; //YS
- if ScreenCursor <> 0 then Exit;
- GetCursorPos( P );
- P := Screen2Client( P );
- if PointInRect( P, ClientRect ) then
- Windows.SetCursor( Value );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.CursorLoad]
- procedure TControl.CursorLoad(Inst: Integer; ResName: PKOLChar);
- begin
- Cursor := LoadCursor( Inst, ResName );
- fCursorShared := TRUE;
- end;
-
- //[procedure TControl.SetIcon]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetIcon( Value: HIcon );
- var OldIco: HIcon;
- begin
- if fIcon = Value then Exit;
- fIcon := Value;
- if Value = THandle(-1) then
- Value := 0;
- OldIco := Perform( WM_SETICON, 1 {ICON_BIG}, Value );
- if OldIco <> 0 then
- DestroyIcon( OldIco );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetMenu]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetMenu( Value: HMenu );
- begin
- if fMenu = Value then Exit;
- if fMenuObj <> nil then
- begin
- {$IFDEF USE_AUTOFREE4CONTROLS}
- RemoveFromAutoFree( fMenuObj );
- {$ENDIF}
- Free_And_Nil(fMenuObj);
- end;
- if fMenu <> 0 then
- DestroyMenu( fMenu );
- fMenu := Value;
- if fHandle = 0 then Exit;
- {$ifdef wince}
- if Value = 0 then
- CeSetMenu(fHandle, nil);
- {$else}
- Windows.SetMenu( fHandle, Value );
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure CallWinHelp]
- procedure CallWinHelp( Context: Integer; CtxCtl: PControl );
- {$ifdef wince}
- begin
- {$else}
- var Cmd: Integer;
- Form: PControl;
- Popup: Boolean;
- begin
- Cmd := HELP_CONTEXT;
- if CtxCtl <> nil then
- begin
- Form := CtxCtl.ParentForm;
- if Form <> nil then
- if Assigned( Form.OnHelp ) then
- begin
- Popup := FALSE;
- Form.OnHelp( CtxCtl, Context, Popup );
- if Popup then
- Cmd := HELP_CONTEXTPOPUP;
- if CtxCtl = nil then Exit;
- end;
- end
- else
- if Context = 0 then
- Cmd := HELP_CONTENTS;
- WinHelp( Applet.Handle, PKOLChar( Applet.GetHelpPath ), Cmd, Context );
- {$endif wince}
- end;
-
- var HHCtrl: THandle;
- HtmlHelp: procedure( Wnd: HWnd; Path: PChar; Cmd, Data: Integer ); {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- //[procedure HtmlHelpCommand]
- procedure HtmlHelpCommand( Wnd: HWnd; const HelpFilePath: String; Cmd, Data: Integer );
- begin
- if HHCtrl = 0 then
- HHCtrl := LoadLibrary( 'HHCTRL.OCX' );
- if HHCtrl = 0 then Exit;
- if not Assigned( HtmlHelp ) then
- HtmlHelp := GetProcAddress( HHCtrl, 'HtmlHelpA' );
- if not Assigned( HtmlHelp ) then Exit;
- HtmlHelp( Wnd, PChar( HelpFilePath ), Cmd, Data );
- end;
-
- //[procedure CallHtmlHelp]
- procedure CallHtmlHelp( Context: Integer; CtxCtl: PControl );
- var Cmd: Integer;
- Form: PControl;
- Popup: Boolean;
- Ids: array[ 0..2 ] of DWORD;
- begin
-
- Cmd := $F; // HH_HELP_CONTEXT;
- if CtxCtl <> nil then
- begin
- Form := CtxCtl.ParentForm;
- if Form <> nil then
- if Assigned( Form.OnHelp ) then
- begin
- Popup := FALSE;
- Form.OnHelp( CtxCtl, Context, Popup );
- if Popup then
- begin
- Cmd := $10; //HH_TP_HELPCONTEXTMENU;
- Ids[ 0 ] := CtxCtl.fMenu;
- Ids[ 1 ] := Context;
- Ids[ 2 ] := 0;
- Context := Integer( @ Ids );
- end;
- if CtxCtl = nil then Exit;
- end;
- end
- else
- if Context = 0 then
- Cmd := 1; // HH_DISPLAY_TOC;
- //ShowMessage( Int2Str( Cmd ) + ' ' + Int2Str( Context ) );
- HtmlHelpCommand( {$IFDEF HTMLHELP_NOTOP} 0 {$ELSE} Applet.Handle {$ENDIF},
- HelpFilePath, Cmd, Context );
- end;
-
- var
- Global_HelpProc: procedure( Context: Integer; CtxCtl: PControl ) = CallWinHelp;
-
- //[function WndProcHelp]
- function WndProcHelp( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var HI: PHelpInfo;
- Ctx: Integer;
- Ctl: PControl;
- begin
- Result := FALSE;
- if Msg.message = WM_HELP then
- begin
- Ctx := 0;
- Ctl := nil;
- HI := Pointer( Msg.lParam );
- if HI.iContextType = HELPINFO_WINDOW then
- begin
- {$IFDEF USE_PROP}
- Ctl := Pointer( GetProp( HI.hItemHandle, ID_SELF ) );
- {$ELSE}
- Ctl := Pointer( GetWindowLong( HI.hItemHandle, GWL_USERDATA ) );
- {$ENDIF}
- while Ctl <> nil do
- begin
- Ctx := Ctl.fHelpContext;
- if Ctx <> 0 then break;
- Ctl := Ctl.Parent;
- end;
- end
- else
- {$ifdef win32}Ctx := GetMenuContextHelpID( HI.hItemHandle ){$endif};
- Applet.CallHelp( Ctx, Ctl );
- Rslt := 1;
- Result := TRUE;
- end
- {$IFDEF AUTO_CONTEXT_HELP}
- else
- if (Msg.message = WM_CONTEXTMENU) then
- begin
- {$IFDEF USE_PROP}
- Ctl := Pointer( GetProp( Msg.wParam, ID_SELF ) );
- {$ELSE}
- Ctl := Pointer( GetWindowLong( Msg.wParam, GWL_USERDATA ) );
- {$ENDIF}
- if (Ctl <> nil) and (Ctl.fHelpContext <> 0) then
- begin
- Applet.CallHelp( Ctl.fHelpContext, Ctl );
- Rslt := 1;
- Result := TRUE;
- end;
- end
- {$ENDIF};
- end;
-
- //[procedure TControl.SetHelpContext]
- procedure TControl.SetHelpContext(Value: Integer);
- var F: PControl;
- begin
- fHelpContext := Value;
- F := ParentForm;
- if F = nil then Exit;
- F.AttachProc( WndProcHelp );
- {$ifdef win32}
- SetWindowContextHelpId( GetWindowHandle, Value );
- {$endif win32}
- end;
-
- //[function TControl.AssignHelpContext]
- function TControl.AssignHelpContext(Context: Integer): PControl;
- begin
- SetHelpContext( Context );
- Result := @ Self;
- end;
-
- //[procedure AssignHtmlHelp]
- procedure AssignHtmlHelp( const HtmlHelpPath: KOLString );
- begin
- Assert( (HtmlHelpPath <> '') and (Applet <> nil), 'Error parameters' );
- if HelpFilePath <> '' then
- FreeMem( HelpFilePath );
- GetMem( HelpFilePath, (Length( HtmlHelpPath ) + 1) * Sizeof( KOLChar ) );
- StrCopy( HelpFilePath, @ HtmlHelpPath[ 1 ] );
- Global_HelpProc := CallHtmlHelp;
- Applet.AttachProc( WndProcHelp );
- end;
-
- //[procedure TControl.CallHelp]
- procedure TControl.CallHelp(Context: Integer; CtxCtl: PControl {; CtlID: Integer} );
- begin
- Global_HelpProc( Context, CtxCtl {, CtlID} );
- end;
-
- //[function TControl.GetHelpPath]
- function TControl.GetHelpPath: KOLString;
- begin
- Result := HelpFilePath;
- if Result = '' then
- begin
- Result := ParamStr( 0 );
- Result := ReplaceFileExt( Result, '.hlp' );
- end;
- end;
-
- //[procedure TControl.SetHelpPath]
- procedure TControl.SetHelpPath(const Value: KOLString);
- begin
- Assert( Value <> '', 'Error parameter' );
- if HelpFilePath <> '' then
- FreeMem( HelpFilePath );
- GetMem( HelpFilePath, (Length( Value ) + 1)*Sizeof( KOLChar ) );
- StrCopy( HelpFilePath, @ Value[ 1 ] );
- end;
- {$ENDIF WIN_GDI}
-
- {$IFDEF ASM_VERSION}
- {$ELSE}
- procedure TControl.DoAutoSize;
- begin
- if Assigned( fAutoSize ) then
- fAutoSize( @Self );
- end;
- {$ENDIF}
-
- {$IFDEF GDI}
- {$IFDEF ASM_UNICODE}
- //[function TControl.GetCaption]
- function TControl.GetCaption: KOLString;
- asm
- PUSH EBX
- PUSH EDI
- XCHG EBX, EAX
- MOV EDI, EDX
- CMP [EBX].fIgnoreWndCaption, 0
- JNZ @@getFCaption
- MOV ECX, [EBX].fHandle
- JECXZ @@getFCaption
- @@getWndCaption:
- PUSH ECX
- CALL GetWindowTextLength
- PUSH EAX
- XCHG EDX, EAX
- LEA EAX, [EBX].fCaption
- CALL System.@LStrSetLength
- POP ECX
- JECXZ @@getFCaption
- INC ECX
- PUSH ECX
- PUSH [EBX].fCaption
- PUSH [EBX].fHandle
- CALL GetWindowText
- @@getFCaption:
- MOV EDX, [EBX].fCaption
- XCHG EAX, EDI
- {$IFNDEF UNICODE_CTRLS}
- CALL System.@LStrAsg
- {$ELSE}
- CALL System.@WStrFromPChar
- {$ENDIF}
-
- @@exit:
- POP EDI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetCaption: KOLString;
- var Sz: Integer;
- begin
- if not fIgnoreWndCaption and (FHandle <> 0) then
- begin
- Sz := GetWindowTextLength( FHandle );
- SetLength( fCaption, Sz );
- if Sz > 0 then
- begin
- {$IFNDEF UNICODE_CTRLS}
- GetWindowText( FHandle, @ fCaption[ 1 ], Sz + 1 );
- {$ELSE}
- GetWindowTextW( FHandle, @ fCaption[ 1 ], Sz + 1 );
- {$ENDIF}
- end;
- end;
- Result := FCaption;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.GetCaption: KOLString;
- begin
- if not fIgnoreWndCaption {and (FHandle <> 0)} then
- FCaption := fGetCaption(@Self);
- Result := FCaption;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF GDI}
- //[procedure TControl.SetCaption]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCaption( const Value: KOLString );
- begin
- fCaption := Value;
- if fHandle <> 0 then
- SendMessage( fHandle, WM_SETTEXT,
- 0, Integer( PKOLChar( Value ) ) );
- if fIsStaticControl <> 1 then
- Invalidate;
- DoAutoSize;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetCaption( const Value: KOLString );
- begin
- fCaption := Value;
- if Assigned( fSetCaption ) then fSetCaption( @Self, Value );
- DoAutoSize;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //[function TControl.GetVisible]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function TControl.GetVisible: Boolean;
- begin
- if (fHandle <> 0) then
- fVisible := IsWindowVisible( fHandle )
- else
- fVisible := (FStyle and WS_VISIBLE) <> 0;
- Result := fVisible;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Get_Visible]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} // Pascal
- function TControl.Get_Visible: Boolean;
- begin
- if (fHandle <> 0) and not fIsControl then
- fVisible := IsWindowVisible( fHandle );
- Result := fVisible;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Set_Visible]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} // Pascal
- procedure TControl.Set_Visible( Value: Boolean );
- {$IFDEF OLD_ALIGN}
- var CmdShow: DWORD;
- begin
- //if Get_Visible <> Value then // commented to allow to set up controls visibility
- begin // on invisible form (Vladimir Piven)
- if Value then
- begin
- fStyle := fStyle or WS_VISIBLE;
- CmdShow := SW_SHOW;
- end
- else
- begin
- fStyle := fStyle and not WS_VISIBLE;
- CmdShow := SW_HIDE;
- end;
- fVisible := Value;
- if fHandle = 0 then Exit;
- {$ifdef wince}
- Perform(WM_SHOWWINDOW, WPARAM(WordBool(Value)), 0);
- {$endif wince}
- ShowWindow( fHandle, CmdShow );
- Global_Align( fParent );
- if Value then
- Global_Align( @Self );
- end;
- if not Value and (fHandle <> 0) then
- fCreateHidden := FALSE; // { +++ }
- {$ELSE NEW_ALIGN}
- begin
- fStyle := fStyle and not WS_VISIBLE;
- if Value then
- fStyle := fStyle or WS_VISIBLE;
- fVisible := Value;
- if fHandle = 0 then Exit;
- {$ifdef wince}
- Perform(WM_SHOWWINDOW, WPARAM(WordBool(Value)), 0);
- {$endif wince}
- if Value then begin
- Global_Align( @Self );
- ShowWindow( fHandle, SW_SHOW );
- end else begin
- fCreateHidden := FALSE; // { +++ }
- ShowWindow( fHandle, SW_HIDE );
- Global_Align( @Self );
- end;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetVisible]
- procedure TControl.SetVisible( Value: Boolean );
- begin
- fCreateVisible := TRUE;
- Set_Visible( Value );
- end;
- {$ENDIF WIN_GDI}
-
- //[function TControl.GetBoundsRect]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetBoundsRect: TRect;
- var W: PControl;
- P: TPoint;
- begin
- Result := fBoundsRect;
- if fHandle <> 0 then
- begin
- GetWindowRect( fHandle, Result );
- if fIsControl or fIsMDIChild then
- begin
- W := fParent; // WindowedParent;
- if W <> nil then
- begin
- P.x := 0; P.y := 0;
- P := W.Client2Screen( P );
- OffsetRect( Result, -P.x, -P.y );
- end;
- end;
- {$IFDEF TEST_BOUNDSRECT}
- if not CompareMem( @ fBoundsRect, @ Result, Sizeof( TRect ) ) then
- {$ENDIF}
- fBoundsRect := Result;
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.GetBoundsRect: TRect;
- var R: TRect;
- window: PGtkWindow;
- requisition: TGtkRequisition;
- begin
- //if fHandle <> nil then
- begin
- if fIsControl then
- begin
- R.Left := fBoundsRect.Left;
- R.Top := fBoundsRect.Top;
- gtk_widget_get_size_request( fEventboxHandle, @ R.Right, @ R.Bottom );
- gtk_widget_size_request( fHandle, @ requisition );
- if R.Right < 0 then R.Right := requisition.width;
- if R.Bottom < 0 then R.Bottom := requisition.height;
- end
- else
- begin
- window := GTK_WINDOW( fHandle );
- gtk_window_get_position(window, @ R.Left, @ R.Top);
- gtk_window_get_size(window, @ R.Right, @ R.Bottom);
- end;
- inc( R.Right, R.Left );
- inc( R.Bottom, R.Top );
- fBoundsRect := R;
- end;
- Result := fBoundsRect;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF GDI}
- //[procedure TControl.SetBoundsRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetBoundsRect( const Value: TRect );
- var Rect: TRect;
- Flags: DWORD;
- cx, cy: integer;
- begin
- Rect := GetBoundsRect;
- if RectsEqual( Value, Rect ) then Exit;
- {$ifdef wince}
- if fIsForm and (fChangedPosSz = 0) then
- Style:=Style or WS_BORDER or WS_CAPTION or WS_SYSMENU;
- fChangedPosSz := fChangedPosSz or $C;
- {$endif wince}
- if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
- if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
- {$IFDEF USE_GRAPHCTLS}
- if not fWindowed then
- Invalidate;
- {$ENDIF}
-
- fBoundsRect := Value;
- if fHandle <> 0 then
- with fBoundsRect do begin
- Flags:=SWP_NOZORDER or SWP_NOACTIVATE;
- cx:=Right - Left;
- cy:=Bottom - Top;
- if (Rect.Right - Rect.Left = cx) and (Rect.Bottom - Rect.Top = cy) then
- Flags:=Flags or SWP_NOSIZE
- else
- if (Left = Rect.Left) and (Top = Rect.Top) then
- Flags:=Flags or SWP_NOMOVE;
- SetWindowPos( fHandle, 0, Left, Top, cx, cy, Flags );
- if fSizeRedraw and (Flags and SWP_NOSIZE = 0) then
- Invalidate;
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetBoundsRect( const Value: TRect );
- var Rect: TRect;
- window: PGtkWindow;
- begin
- Rect := GetBoundsRect;
- if RectsEqual( Value, Rect ) then Exit;
- if Value.Left <> fBoundsRect.Left then fChangedPosSz := fChangedPosSz or 1;
- if Value.Top <> fBoundsRect.Top then fChangedPosSz := fChangedPosSz or 2;
- fBoundsRect := Value;
- Rect := Value;
-
- if fIsControl then
- begin
- //gtk_widget_set_uposition( fHandle, Rect.Left, Rect.Top );
- if fParent <> nil then
- fParent.fChildSetPos( fParent, @ Self, Rect.Left, Rect.Top );
- if (Rect.Right > Rect.Left) and (Rect.Bottom > Rect.Top) then
- gtk_widget_set_size_request( fEventboxHandle,
- Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
- end
- else
- begin
- window := GTK_WINDOW( fHandle );
- gtk_window_move( window, Rect.Left, Rect.Top );
- gtk_window_resize( window, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top );
- end;
- //if fSizeRedraw then
- // Invalidate;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- const
- WindowStateShowCommands: array[TWindowState] of Byte =
- (SW_SHOWNOACTIVATE, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
- //[procedure TControl.SetWindowState]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetWindowState( Value: TWindowState );
- begin
- if fWindowState <> Value then
- begin
- fWindowState := Value;
- ShowWindow(GetWindowHandle, WindowStateShowCommands[Value]);
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Show]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.Show;
- begin
- CreateWindow;
- SetVisible( True );
- SetForegroundWindow( Handle );
- DoSetFocus;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Hide]
- procedure TControl.Hide;
- begin
- SetVisible( False );
- end;
-
- //[function TControl.Client2Screen]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Client2Screen( const P: TPoint ): TPoint;
- begin
- Result := P;
- if fHandle <> 0 then
- Windows.ClientToScreen( fHandle, Result );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Screen2Client]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Screen2Client( const P: TPoint ): TPoint;
- begin
- Result := P;
- if Handle <> 0 then
- Windows.ScreenToClient( Handle, Result );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
-
-
- //[function TControl.ClientRect]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ClientRect: TRect;
- begin
- Result := fBoundsRect;
- GetWindowHandle;
- if (fHandle <> 0) then
- GetClientRect( fHandle, Result );
- Inc( Result.Top, fClientTop );
- Dec( Result.Bottom, fClientBottom );
- Inc( Result.Left, fClientLeft );
- Dec( Result.Right, fClientRight );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.ClientRect: TRect; //todo: implement exact, now for PaintBox only
- begin
- Result := fBoundsRect;
- OffsetRect( Result, -Result.Left, -Result.Top );
- Inc( Result.Top, fClientTop );
- Dec( Result.Bottom, fClientBottom );
- Inc( Result.Left, fClientLeft );
- Dec( Result.Right, fClientRight );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.Invalidate]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE PAS_VERSION}
- procedure TControl.Invalidate;
- begin
- {$IFDEF USE_GRAPHCTLS}
- fDoInvalidate;
- {$ELSE}
- if fHandle <> 0 then
- InvalidateRect( fHandle, nil, TRUE );
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.Invalidate;
- begin
- gtk_widget_queue_draw_area( fHandle, 0, 0, Width, Height );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- {$IFDEF USE_GRAPHCTLS}
- procedure TControl.InvalidateNonWindowed;
- var R: TRect;
- begin
- R := BoundsRect;
- if fParent.fHandle <> 0 then
- InvalidateRect( fParent.fHandle, @ R, TRUE );
- end;
-
- //[procedure TControl.InvalidateWindowed]
- {$IFDEF ASM_VERSION}
- {$ELSE PAS_VERSION}
- procedure TControl.InvalidateWindowed;
- begin
- if fHandle <> 0 then
- InvalidateRect( fHandle, nil, TRUE );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF USE_GRAPHCTLS}
-
- //[function TControl.GetIcon]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetIcon: HIcon;
- begin
- Result := fIcon;
- if Result = THandle( -1 ) then
- begin
- Result := 0;
- Exit;
- end;
- if Result = 0 then
- if (Assigned( Applet )) and
- (@Self <> Applet) then
- begin
- Result := Applet.Icon;
- {$ifdef wince}
- fIconShared := TRUE;
- {$else}
- if Result <> 0 then
- Result := CopyImage( Result, IMAGE_ICON, 0, 0, 0 );
- {$endif}
- end
- else
- begin
- Result := LoadIcon( hInstance,
- {$IFDEF CUSTOM_APPICON}
- {$I CusomAppIconRsrcName_PAS.inc} // create such file with 'your icon rsrc name'
- {$ELSE} 'MAINICON' {$ENDIF} );
- end;
- fIcon := Result;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[procedure TControl.IconLoad]
- procedure TControl.IconLoad(Inst: Integer; ResName: PKOLChar);
- begin
- Icon := LoadIcon( Inst, ResName );
- fIconShared := TRUE;
- end;
-
- //[procedure TControl.IconLoadCursor]
- procedure TControl.IconLoadCursor(Inst: Integer; ResName: PKOLChar);
- begin
- Icon := LoadCursor( Inst, ResName );
- fIconShared := TRUE;
- end;
-
- //[function TControl.CallDefWndProc]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.CallDefWndProc(var Msg: TMsg): Integer;
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.CallDefWndProc FHandle = ' + Int2Str( FHandle ) +
- ', Msg.hwd = ' + Int2Str( Msg.hwnd ) );
- TRY
- {$ENDIF INPACKAGE}
- if FDefWndProc <> nil then
- begin
- {$IFDEF INPACKAGE}
- Log( '//// CallWindowProc, FDefWndProc = ' + Int2Hex( DWORD( FDefWndProc ), 6 ) );
- TRY
- TRY
- {$ENDIF INPACKAGE}
- Result := CallWindowProc( FDefWndProc, FHandle, Msg.message, Msg.wParam, Msg.lParam );
- {$IFDEF INPACKAGE}
- EXCEPT on E: Exception do
- Log( '*** Exception in CallWindowProc, msg = ' + E.Message );
- END;
- EXCEPT
- Log( '*** Exception handled' );
- END;
- {$ENDIF INPACKAGE}
- end
- else
- begin
- {$IFDEF INPACKAGE}
- Log( '//// DefWindowProc' );
- {$ENDIF INPACKAGE}
- Result := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
- end;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.CallDefWndProc' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetWindowState]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetWindowState: TWindowState;
- begin
- Result := fWindowState;
- {$ifdef win32}
- if Handle <> 0 then
- begin
- if IsIconic( Handle ) then
- Result := wsMinimized
- else
- if IsZoomed( Handle ) then
- Result := wsMaximized
- else
- Result := wsNormal;
- fWindowState := Result;
- end;
- {$endif win32}
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.DoSetFocus]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.DoSetFocus: Boolean;
- begin
- Result := False;
- if Enabled and (fTabstop or (fStyle and WS_TABSTOP <> 0)) then
- begin
- Inc( fClickDisabled );
- SetFocus( fHandle );
- Dec( fClickDisabled );
- Result := True;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.HandleAllocated]
- function TControl.HandleAllocated: Boolean;
- begin
- Result := FHandle <> 0;
- end;
-
- //[function TControl.GetEnabled]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetEnabled: Boolean;
- begin
- if FHandle = 0 then
- Result := (Style and WS_DISABLED) = 0
- else
- Result := IsWindowEnabled( FHandle );
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- //[function TControl.IsMainWindow]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.IsMainWindow: Boolean;
- begin
- if Applet = nil then
- Result := not IsControl
- else if not AppButtonUsed then
- Result := @ Self = Applet
- else
- Result := Applet.Children[ 0 ] = @ Self;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[function TControl.get_ClassName]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.get_ClassName: KOLString;
- begin
- {$ifndef wince}
- if not fCtlClsNameChg then
- Result := 'obj_' + fControlClassName
- else
- {$endif wince}
- Result := fControlClassName;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.set_ClassName]
- procedure TControl.set_ClassName(const Value: KOLString);
- begin
- if fCtlClsNameChg then
- FreeMem( fControlClassName );
- GetMem( fControlClassName, (Length( Value ) + 1) * Sizeof( KOLChar ) );
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( fControlClassName, @ Value[ 1 ] );
- fCtlClsNameChg := TRUE;
- end;
-
- //[function WndProcQueryEndSession]
- function WndProcQueryEndSession( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Accept: Boolean;
- begin
- Result := FALSE;
- if Msg.message = WM_QUERYENDSESSION then
- begin
- if Assigned( Sender.fOnQueryEndSession ) then
- begin
- Accept := TRUE;
- Sender.fCloseQueryReason := qShutdown;
- if LongBool(Msg.lParam and {ENDSESSION_LOGOFF} DWORD($80000000)) then
- Sender.fCloseQueryReason := qLogoff;
- Sender.fOnQueryEndSession( Sender, Accept );
- Sender.fCloseQueryReason := qClose;
- Rslt := Integer( Accept );
- // Äîáàâèòü. Íóæíî äëÿ òîãî, ÷òîáû îòìåíèëîñü çàâåðøåíèå ñåàíñà,
- // åñëè Accept óñòàíîâëåí â False è ñåàíñ çàâåðøèëñÿ ïðè Accept = True
- // Add (YS). To cancel ending session if Accept=FALSE but allow ending
- // session if Accept=TRUE.
- Result := True; // {YS}: no further processing
- end;
- end;
- end;
-
- //[procedure TControl.SetOnQueryEndSession]
- procedure TControl.SetOnQueryEndSession(const Value: TOnEventAccept);
- begin
- AttachProc( WndProcQueryEndSession );
- fOnQueryEndSession := Value;
- end;
-
- //[function WndProcMinMaxRestore]
- function WndProcMinMaxRestore( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if Msg.message = WM_SYSCOMMAND then
- begin
- case Msg.wParam and not 15 of
- SC_MINIMIZE: if Assigned( Sender.fOnMinimize ) then
- Sender.fOnMinimize( Sender );
- SC_MAXIMIZE: if Assigned( Sender.fOnMaximize ) then
- Sender.fOnMaximize( Sender );
- SC_RESTORE: if Assigned( Sender.fOnRestore ) then
- Sender.fOnRestore( Sender );
- end;
- end;
- end;
-
- //[procedure TControl.SetOnMinMaxRestore]
- procedure TControl.SetOnMinMaxRestore(const Index: Integer;
- const Value: TOnEvent);
- type POnEvent = ^TOnEvent;
- {$IFDEF F_P}
- var Ptr1: Pointer;
- {$ELSE DELPHI}
- var Ev: POnEvent;
- {$ENDIF F_P/DELPHI}
- begin
- AttachProc( WndProcMinMaxRestore );
- {$IFDEF F_P}
- Ptr1 := Self;
- asm
- MOV EAX, [Ptr1]
- LEA EAX, [EAX].TControl.fOnMinimize
- ADD EAX, [Index]
- MOV EDX, [Value]
- MOV [EAX], EDX
- MOV EDX, [Value+4]
- MOV [EAX+4], EDX
- end [ 'EAX', 'EDX' ];
- {$ELSE DELPHI}
- Ev := Pointer( cardinal( @ TMethod( fOnMinimize ).Code ) + cardinal(Index) );
- Ev^ := Value;
- {$ENDIF}
- end;
-
- procedure TControl.SetOnMinimize(const Value: TOnEvent);
- begin
- SetOnMinMaxRestore( 0, Value );
- end;
-
- procedure TControl.SetOnMaximize(const Value: TOnEvent);
- begin
- SetOnMinMaxRestore( 8, Value );
- end;
-
- procedure TControl.SetOnRestore(const Value: TOnEvent);
- begin
- SetOnMinMaxRestore( 16, Value );
- end;
-
- {$IFDEF F_P}
- //[function TControl.GetOnMinMaxRestore]
- function TControl.GetOnMinMaxRestore(const Index: Integer): TOnEvent;
- begin
- CASE Index OF
- 0: Result := fOnMinimize;
- 8: Result := fOnMaximize;
- 16: Result := fOnRestore;
- END;
- end;
- {$ENDIF F_P}
-
- {$IFDEF INPACKAGE}
- {$IFDEF ASM_LOCAL}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
- {$ELSE}
- {$IFDEF ASM_VERSION}
- {$DEFINE ASM_LOCAL}
- {$ENDIF}
- {$ENDIF}
-
- {$ENDIF WIN_GDI}
-
- {$IFDEF GDI}
- //[procedure TControl.SetParent]
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetParent( Value: PControl );
- begin
- if Value = fParent then Exit;
- if fParent <> nil then
- begin
- {$IFDEF USE_GRAPHCTLS}
- Invalidate; // necessary for graphic controls
- {$ENDIF}
- {$IFDEF DEBUG_MCK}
- if Assigned( fParent.fChildren ) then
- begin
- mck_Log( 'remove from old parent children 1st' );
- fParent.fChildren.Remove( @Self );
- mck_Log( 'removed ok' );
- end;
- {$ELSE not DEBUG_MCK}
- fParent.fChildren.Remove( @Self );
- {$IFDEF NOT_USE_AUTOFREE4CONTROLS}
- {$ELSE}
- fParent.RemoveFromAutoFree( @Self );
- {$ENDIF}
-
- if Assigned( fParent.fNotifyChild ) then
- fParent.fNotifyChild( fParent, nil );
- {$ENDIF not DEBUG_MCK}
- end;
- fParent := Value;
- if fParent <> nil then
- begin
- fParent.fChildren.Add( @Self );
- {$IFDEF USE_AUTOFREE4CHILDREN}
- fParent.Add2AutoFree( @ Self );
- {$ENDIF}
- {$IFNDEF INPACKAGE} //-----------------------------------------------------
- if FHandle <> 0 then
- Windows.SetParent( FHandle, Value.GetWindowHandle );
- {$ENDIF not INPACKAGE} //--------------------------------------------------
- if Assigned( fParent.fNotifyChild ) then
- fParent.fNotifyChild( fParent, @ Self );
- if Assigned( fNotifyChild ) then
- fNotifyChild( fParent, @ Self );
- {$IFDEF USE_GRAPHCTLS}
- Invalidate; // necessary for graphic controls
- {$ENDIF}
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetParent( Value: PControl );
- begin
- if Value = fParent then Exit;
- if fParent <> nil then
- begin
- fParent.fChildren.Remove( @Self );
-
- {$IFDEF NOT_USE_AUTOFREE4CONTROLS}
- {$ELSE}
- fParent.RemoveFromAutoFree( @Self );
- {$ENDIF}
- end;
- fParent := Value;
- if fParent <> nil then
- begin
- fParent.fChildren.Add( @Self );
- {$IFDEF USE_AUTOFREE4CHILDREN}
- fParent.Add2AutoFree( @ Self );
- {$ENDIF}
- end;
- fParent.fGetClientArea( fParent );
- fParent.fChildPut( fParent, @ Self, fBoundsRect.Left, fBoundsRect.Top );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[function TControl.ChildIndex]
- function TControl.ChildIndex(Child: PControl): Integer;
- begin
- Result := fChildren.IndexOf( Child );
- end;
-
- //*
- //[procedure TControl.MoveChild]
- procedure TControl.MoveChild(Child: PControl; NewIdx: Integer);
- var I: Integer;
- begin
- I := ChildIndex( Child );
- Assert( I>=0, 'TControl.MoveChild: index out of bounds' );
- fChildren.MoveItem( I, NewIdx );
- end;
-
- {$IFDEF WIN_GDI}
- //[procedure TControl.EnableChildren]
- procedure TControl.EnableChildren(Enable, Recursive: Boolean);
- var I: Integer;
- C: PControl;
- begin
- for I := 0 to ChildCount-1 do
- begin
- C := Children[ I ];
- C.Enabled := Enable;
- if Recursive then
- C.EnableChildren( Enable, TRUE );
- end;
- end;
-
- {$ENDIF WIN_GDI}
- //[constructor TControl.CreateParented]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- constructor TControl.CreateParented(AParent: PControl);
- begin
- InitParented( AParent ); // because InitParented is virtual, but CreateParented
- end; // can not be virtual (as an _object_ - not a class - constructor)
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- constructor TControl.CreateParented(AParent: PControl; widget: PGtkWidget;
- need_eventbox: Boolean);
- begin
- InitParented( AParent, widget, need_eventbox );
- // because InitParented is virtual, but CreateParented
- end; // can not be virtual (as an _object_ - not a class - constructor)
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[function TControl.GetLeft]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetLeft: Integer;
- begin
- Result := BoundsRect.Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetLeft]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetLeft( Value: Integer );
- var R: TRect;
- begin
- R := BoundsRect;
- R.Left := Value;
- R.Right := Value + Width;
- SetBoundsRect( R );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetTop]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetTop: Integer;
- begin
- Result := BoundsRect.Top;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetTop]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetTop( Value: Integer );
- var R: TRect;
- begin
- R := BoundsRect;
- R.Top := Value;
- R.Bottom := Value + Height;
- SetBoundsRect( R );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetWidth: Integer;
- begin
- with BoundsRect do
- Result := Right - Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetWidth( Value: Integer );
- var R: TRect;
- begin
- R := BoundsRect;
- with R do
- Right := Left + Value;
- SetBoundsRect( R );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetHeight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetHeight: Integer;
- begin
- with BoundsRect do
- Result := Bottom - Top;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetHeight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetHeight( Value: Integer );
- var R: TRect;
- begin
- R := BoundsRect;
- with R do
- Bottom := Top + Value;
- SetBoundsRect( R );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetPosition]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetPosition: TPoint;
- begin
- Result.x := BoundsRect.Left;
- Result.y := BoundsRect.Top;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Set_Position]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.Set_Position( Value: TPoint );
- var R: TRect;
- begin
- R.Top := Value.y;
- R.Left := Value.x;
- R.Right := R.Left + Width;
- R.Bottom := R.Top + Height;
- BoundsRect := R;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[function WndProcConstraints]
- function WndProcConstraints( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var MMI: PMinMaxInfo;
- begin
- Result := FALSE;
- if Msg.message = WM_GETMINMAXINFO then
- begin
- Rslt := Sender.CallDefWndProc( Msg );
- MMI := Pointer( Msg.lParam );
- if Sender.FMaxWidth > 0 then
- begin
- MMI.ptMaxSize.x := Sender.FMaxWidth;
- MMI.ptMaxTrackSize.x := Sender.FMaxWidth;
- end;
- if Sender.FMaxHeight > 0 then
- begin
- MMI.ptMaxSize.y := Sender.FMaxHeight;
- MMI.ptMaxTrackSize.y := Sender.FMaxHeight;
- end;
- MMI.ptMinTrackSize := MakePoint( Sender.FMinWidth, Sender.FMinHeight );
- Rslt := 0;
- Result := TRUE;
- end;
- end;
-
- {$IFDEF USE_MHTOOLTIP}
- {$DEFINE implementation}
- {$I KOLMHToolTip.pas}
- {$UNDEF implementation}
- {$ENDIF}
-
- //[procedure TControl.SetConstraint]
- procedure TControl.SetConstraint(const Index, Value: Integer);
- begin
- AttachProc( WndProcConstraints );
- case Index of
- 0: FMinWidth := Value;
- 1: FMinHeight := Value;
- 2: FMaxWidth := Value;
- 3: FMaxHeight := Value;
- end;
- end;
-
- {$IFDEF F_P}
- //[function TControl.GetConstraint]
- function TControl.GetConstraint(const Index: Integer): Integer;
- begin
- CASE Index OF
- 0: Result := FMinWidth;
- 1: Result := FMinHeight;
- 2: Result := FMaxWidth;
- 3: Result := FMaxHeight;
- END;
- end;
- {$ENDIF F_P}
-
- //*
- //[function TControl.ControlRect]
- function TControl.ControlRect: TRect;
- var C: PControl;
- R: TRect;
- begin
- Result := BoundsRect;
- C := Parent;
- if C <> nil then
- begin
- if not C.fIsControl then Exit;
-
- R := C.ControlRect;
- OffsetRect( Result, R.Left, R.Top );
-
- if C.fChildren <> nil then
- if C.FChildren.IndexOf( @Self ) >= C.MembersCount then
- begin
- R := C.ClientRect;
- Dec( R.Top, C.fClientTop );
- Dec( R.Left, C.fClientLeft );
- OffsetRect( Result, R.Left, R.Top );
- end;
- end;
- end;
-
- //*
- //[function TControl.ControlAtPos]
- function TControl.ControlAtPos( X, Y: Integer;
- IgnoreDisabled: Boolean ): PControl;
- var I: Integer;
- C: PControl;
- CR, VR: TRect;
- begin
- Result := nil;
- CR := ControlRect;
- if Windowed then
- CR := MakeRect( 0, 0, 0, 0 );
- X := X + CR.Left; // - R.Left;
- Y := Y + CR.Top; // - R.Top;
- for I := ChildCount { + MembersCount } - 1 downto 0 do
- begin
- C := Children[ I ]; //Members[ I ];
- if C.Visible then
- if (not IgnoreDisabled) or IgnoreDisabled and C.Enabled then
- begin
- VR := C.ControlRect;
- if (X >= VR.Left) and (X < VR.Right) and
- (Y >= VR.Top) and (Y < VR.Bottom) then
- begin
- Result := C;
- Exit;
- end;
- end;
- end;
- end;
- {$ENDIF WIN_GDI}
-
- //[PROCEDURE DefaultPaintBackground]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure DefaultPaintBackground( Sender: PControl; DC: HDC; Rect: PRect );
- {$IFDEF GDI} var B: HBrush; {$ENDIF GDI}
- begin
- {$IFDEF GDI}
- B := CreateSolidBrush( Color2Rgb( Sender.Color ) );
- Windows.FillRect( DC, Rect^, B );
- DeleteObject( B );
- {$ENDIF GDI}
- end;
- {$ENDIF ASM_VERSION}
- //[END DefaultPaintBackground]
-
- {$IFDEF WIN_GDI}
- //[procedure TControl.PaintBackground]
- procedure TControl.PaintBackground( DC: HDC; Rect: PRect );
- begin
- Global_OnPaintBkgnd( @Self, DC, Rect );
- end;
- {$ENDIF WIN_GDI}
-
- //[procedure TControl.SetCtlColor]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCtlColor( Value: TColor );
- begin
- {$IFNDEF INPACKAGE}
- if GetWindowHandle <> 0 then
- {$ELSE}
- if fHandle <> 0 then
- {$ENDIF}
- if fCommandActions.aSetBkColor <> 0 then
- Perform( fCommandActions.aSetBkColor, 0, Color2RGB( Value ) );
- if fColor = Value then Exit;
- fColor := Value;
- if fTmpBrush <> 0 then
- begin
- DeleteObject( fTmpBrush );
- fTmpBrush := 0;
- end;
- if fBrush <> nil then
- fBrush.Color := Value;
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetCtlColor( Value: TColor );
- var gcolor: TGdkColor;
- i: Integer;
- begin
- if fColor = Value then Exit;
- fColor := Value;
-
- //oldfontdesc := PGtkWidget( _Self.fHandle ).style.font_desc;
- gcolor := Color2GdkColor( Value );
- for i := 0 to 4 do
- begin
- gtk_widget_modify_bg( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
- gtk_widget_modify_base( fEventboxHandle, {GTK_STATE_NORMAL} i, @ gcolor );
- end;
- //if Assigned( _Self.fFont ) then
- {begin
- _Self.fHandle.style.font_desc :=
- pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
- if oldfontdesc <> nil then
- pango_font_description_free( oldfontdesc );
- end;}
-
- //Invalidate;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //[function TControl.GetParentWnd]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetParentWnd( NeedHandle: Boolean ): HWnd;
- var C: PControl;
- begin
- Result := 0;
- C := fParent; // WindowedParent;
- if C <> nil then
- begin
- if NeedHandle then
- C.GetWindowHandle;
- Result := C.fHandle;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.CreateChildWindows]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.CreateChildWindows;
- var I: Integer;
- C: PControl;
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.CreateChildWindows' );
- TRY
- {$ENDIF INPACKAGE}
- for I := 0 to fChildren.Count - 1 do
- begin
- {$IFDEF INPACKAGE}
- Log( Int2Str( I ) );
- {$ENDIF INPACKAGE}
- C := fChildren.fItems[ I ];
- C.CreateWindow; //virtual!!!
- end;
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.CreateChildWindows' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[function TControl.GetMembers]
- function TControl.GetMembers(Idx: Integer): PControl;
- begin
- Result := fChildren.Items[ Idx ];
- // Important: .Items but not .fItems - when fChildren.Count=0, nil is returned
- end;
- {$IFDEF WIN_GDI}
-
- //[procedure TControl.DestroyChildren]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.DestroyChildren;
- var I: Integer;
- W: PControl;
- begin
- for I := fChildren.fCount - 1 downto 0 do
- begin
- W := fChildren.fItems[ I ];
- W.Free;
- end;
- fChildren.Clear;
- end;
- {$ENDIF ASM_VERSION}
-
- {//-
- //[function TControl.WindowedParent]
- function TControl.WindowedParent: PControl;
- begin
- Result := fParent;
- end;}
-
- //[function TControl.ProcessMessage]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ProcessMessage: Boolean;
- begin
- Result := InternalProcessMessage(nil);
- end;
- {$ENDIF ASM_VERSION}
-
- function TControl.InternalProcessMessage(AMsg: PMsg): Boolean;
- var Msg: TMsg;
- begin
- Result := False;
- if AMsg <> nil then
- Msg:=AMsg^
- else
- if not PeekMessage( Msg, 0, 0, 0, PM_REMOVE ) then
- exit;
- Result := Msg.message <> 0;
- if (Msg.message = WM_QUIT) then
- begin
- AppletTerminated := True;
- {$IFDEF PROVIDE_EXITCODE}
- ExitCode := Msg.wParam;
- {$ENDIF PROVIDE_EXITCODE}
- end
- else
- begin
- if not(Assigned( fExMsgProc ) and fExMsgProc( @Self, Msg )) then
- begin
- TranslateMessage( Msg );
- DispatchMessage( Msg );
- {$IFDEF PSEUDO_THREADS}
- if Assigned( MainThread ) then
- MainThread.NextThread;
- {$ENDIF}
- end;
- end;
- end;
-
- procedure TControl.WaitAndProcessMessages;
- var Msg: TMsg;
- begin
- GetMessage(Msg, 0, 0, 0);
- InternalProcessMessage(@Msg);
- while InternalProcessMessage(nil) do ;
- end;
-
- //[procedure TControl.ProcessMessages]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.ProcessMessages;
- begin
- while ProcessMessage do ;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.ProcessMessagesEx]
- procedure TControl.ProcessMessagesEx;
- begin
- PostMessage( GetWindowHandle, CM_PROCESS, 0, 0 );
- ProcessMessages;
- end;
-
- //-
- //[procedure TControl.ProcessPendingMessages]
- procedure TControl.ProcessPendingMessages;
- var Msg: TMsg;
- begin
- if LOWORD( GetQueueStatus( QS_ALLINPUT ) ) <> 0 then
- if PeekMessage( Msg, 0, 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
- or PeekMessage( Msg, HWnd(-1), 0, 0, PM_NOREMOVE {or PM_NOYIELD} )
- then
- Applet.ProcessMessages;
- end;
-
- //[procedure TControl.ProcessPaintMessages]
- procedure TControl.ProcessPaintMessages;
- var Msg: TMsg;
- begin
- while PeekMessage( Msg, Handle, 15, 15, PM_NOREMOVE ) do
- Applet.ProcessMessage;
- end;
-
- //[FUNCTION WndProcForm]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcForm(Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- {$IFDEF ENDSESSION_HALT}
- var App: PControl;
- {$ENDIF}
- begin
- Result := True;
- with Self_{-}^{+} do
- case Msg.message of
- {$IFDEF ENDSESSION_HALT}
- WM_ENDSESSION:
- begin
- if Msg.wParam <> 0 then
- begin
- Self_.RefDec;
- { Normally, WM_ENDSESSION is sent to a main form, not to Applet.
- Since we do not plan further working after handling this message,
- we decrease RefCount for the form (in was increased in EnumDynHandlers
- to prevent object destroying while its message processing is not
- finished). }
- App := Applet;
- //Rslt := 0; { We will not return any result at all. }
- {$IFDEF DEBUG_ENDSESSION}
- EndSession_Initiated := TRUE;
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'Self_=' + Int2Hex( DWORD( Self_ ), 8 ) +
- ' Self_.Handle=' + Int2Str( Self_.FHandle ) );
- {$ENDIF}
- AppletTerminated := TRUE;
- AppletRunning := FALSE;
- Applet := nil;
- App.Free; { We provide OnDestroy handlers to be called for any objects here }
- Halt; { Stop further executing. }
- end else Result := FALSE;
- end;
- {$ENDIF ENDSESSION_HALT}
- WM_SETFOCUS:
- begin
- {$IFDEF NEW_MODAL}
- if fModalForm <> nil then
- SetFocus( fModalForm.fHandle )
- else if ( FCurrentControl <> nil ) and not ( fCurrentControl.IsForm xor fIsApplet ) then
- {$ELSE not NEW_MODAL}
- if FCurrentControl <> nil then
- {$ENDIF}
- begin
- if FCurrentControl.CreateWindow then
- SetFocus( FCurrentControl.fHandle );
- end
- else
- Result := False;
- if assigned( Applet ) and (Applet <> Self_) then
- Applet.FCurrentControl := Self_;
- end;
- {$IFDEF SNAPMOUSE2DFLTBTN}
- WM_INITDIALOG:
- begin
- asm
- nop
- end;
- Result := FALSE;
- end;
- {$ENDIF}
- else Result := False;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcForm]
-
- {$ENDIF WIN_GDI}
- //[FUNCTION GetPrevCtrlBoundsRect]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function GetPrevCtrlBoundsRect( P: PControl; var R: TRect ): Boolean;
- var Idx: Integer;
- begin
- Result := False;
- if P.FParent = nil then Exit;
- Idx := P.FParent.ChildIndex( P ) - 1;
- if Idx < 0 then Exit;
- Result := True;
- R := P.FParent.Children[ Idx ].BoundsRect;
- end;
- {$ENDIF ASM_VERSION}
- //[END GetPrevCtrlBoundsRect]
-
- //[function TControl.PlaceUnder]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.PlaceUnder: PControl;
- var R: TRect;
- begin
- Result := @Self;
- if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
- Top := R.Bottom + fParent.fMargin;
- Left := R.Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.PlaceDown]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.PlaceDown: PControl;
- var R: TRect;
- begin
- Result := @Self;
- if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
- Top := R.Bottom + fParent.fMargin;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.PlaceRight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.PlaceRight: PControl;
- var R: TRect;
- begin
- Result := @Self;
- if not GetPrevCtrlBoundsRect( @Self, R ) then Exit;
- Top := R.Top;
- Left := R.Right + fParent.fMargin;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.SetSize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.SetSize(W, H: Integer): PControl;
- var R: TRect;
- begin
- R := BoundsRect;
- if W > 0 then R.Right := R.Left + W;
- if H > 0 then R.Bottom := R.Top + H;
- SetBoundsRect( R );
- Result := @Self;
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- //[function TControl.SetClientSize]
- function TControl.SetClientSize(W, H: Integer): PControl;
- begin
- if W > 0 then ClientWidth := W;
- if H > 0 then ClientHeight := H;
- Result := @Self;
- end;
-
- //[function TControl.AlignLeft]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.AlignLeft(P: PControl): PControl;
- begin
- Result := @Self;
- Left := P.Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.AlignTop]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.AlignTop(P: PControl): PControl;
- begin
- Result := @Self;
- Top := P.Top;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF KEY_PREVIEW}
- {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- {$ENDIF}
- {$IFDEF ESC_CLOSE_DIALOGS}
- {$IFNDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- {$DEFINE KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- {$ENDIF}
- {$ENDIF}
-
- //[FUNCTION WndProcCtrl]
- {$IFDEF ASM_VERSION} // see addition for combobox in pas version
- function WndProcCtrl( Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- asm //cmd //opd
- PUSH EBX
- XCHG EBX, EAX
- PUSH ESI
- PUSH EDI
- MOV EDI, EDX
- MOV EDX, [EDI].TMsg.message
-
- SUB DX, CN_CTLCOLORMSGBOX
- CMP DX, CN_CTLCOLORSTATIC-CN_CTLCOLORMSGBOX
- JA @@chk_CM_COMMAND
- @@2:
- PUSH ECX
- MOV EAX, [EBX].TControl.fTextColor
- CALL Color2RGB
- XCHG ESI, EAX
- PUSH ESI
- PUSH [EDI].TMsg.wParam
- CALL SetTextColor
- CMP [EBX].TControl.fTransparent, 0
- JZ @@opaque
-
- PUSH Windows.TRANSPARENT
- PUSH [EDI].TMsg.wParam
- CALL SetBkMode
- PUSH NULL_BRUSH
- CALL GetStockObject
- JMP @@ret_rslt
-
- @@opaque:
- MOV EAX, [EBX].TControl.fColor
- CALL Color2RGB
- XCHG ESI, EAX
- PUSH OPAQUE
- PUSH [EDI].TMsg.wParam
- CALL SetBkMode
- PUSH ESI
- PUSH [EDI].TMsg.wParam
- CALL SetBkColor
-
- MOV EAX, EBX
- CALL Global_GetCtlBrushHandle
- @@ret_rslt:
- XCHG ECX, EAX
- @@tmpbrushready:
- POP EAX
- MOV [EAX], ECX
- @@ret_true:
- MOV AL, 1
-
- JMP @@ret_EAX
-
- @@chk_CM_COMMAND:
- CMP word ptr [EDI].TMsg.message, CM_COMMAND
- JNE @@chk_WM_SETFOCUS
-
- PUSH ECX
-
- MOVZX ECX, word ptr [EDI].TMsg.wParam+2
- CMP CX, [EBX].TControl.fCommandActions.aClick
- JNE @@chk_aEnter
-
- CMP [EBX].TControl.fClickDisabled, 0
- JG @@calldef
- MOV EAX, EBX
- MOV DL, 1
- CALL TControl.SetFocused
- MOV EAX, EBX
- CALL TControl.DoClick
- JMP @@calldef
-
- @@chk_aEnter:
- LEA EAX, [EBX].TControl.fOnEnter
- CMP CX, [EBX].TControl.fCommandActions.aEnter
- JE @@goEvent
- LEA EAX, [EBX].TControl.fOnLeave
- CMP CX, [EBX].TControl.fCommandActions.aLeave
- JE @@goEvent
- LEA EAX, [EBX].TControl.fOnChange
- CMP CX, [EBX].TControl.fCommandActions.aChange
- JNE @@chk_aSelChange
- @@goEvent:
- MOV ECX, [EAX].TMethod.Code
- JECXZ @@2calldef
- MOV EAX, [EAX].TMethod.Data
- MOV EDX, EBX
- CALL ECX
- @@2calldef:
- JMP @@calldef
-
- @@chk_aSelChange:
- CMP CX, [EBX].TControl.fCommandActions.aSelChange
- JNE @@chk_WM_SETFOCUS_1
- MOV EAX, EBX
- CALL TControl.DoSelChange
-
- @@calldef:
- XCHG EAX, EBX
- MOV EDX, EDI
- CALL TControl.CallDefWndProc
- JMP @@ret_rslt
-
- @@chk_WM_SETFOCUS_1:
- POP ECX
- @@chk_WM_SETFOCUS:
- XOR EAX, EAX
- CMP word ptr [EDI].TMsg.message, WM_SETFOCUS
- JNE @@chk_WM_KEYDOWN
-
- MOV [ECX], EAX
- MOV EAX, EBX
- CALL TControl.ParentForm
- TEST EAX, EAX
- JZ @@ret_true
-
- PUSH EAX
- MOV ECX, [EAX].TControl.FCurrentControl
- JECXZ @@a1
- CMP ECX, EBX
- JZ @@a1
- XCHG EAX, ECX
- MOV ECX, [EAX].TControl.fLeave.TMethod.Code
- JECXZ @@a1
- XCHG EDX, EAX
- MOV EAX, [EDX].TControl.fLeave.TMethod.Data
- CALL ECX
- @@a1: POP EAX
-
- MOV [EAX].TControl.FCurrentControl, EBX
- XOR EAX, EAX
-
- PUSH EDX
- @@2ret_EAX:
- POP EDX
-
- @@chk_WM_KEYDOWN:
- {$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- CMP word ptr [EDI].TMsg.message, WM_KEYDOWN
- {$IFDEF KEY_PREVIEW}
- JNE @@chk_other_KEYMSGS
- {$ELSE}
- JNE @@ret0
- {$ENDIF}
-
- {$IFDEF KEY_PREVIEW}
- MOV EAX, EBX
- CALL TControl.ParentForm
- CMP EAX, EBX
- JE @@kp_end
-
- CMP [EAX].TControl.fKeyPreview, 0
- JZ @@kp_end
-
- MOV [EAX].TControl.fKeyPreviewing, 1
- INC [EAX].TControl.fKeyPreviewCount
- PUSH EAX
-
- PUSH [EDI].TMsg.lParam
- PUSH [EDI].TMsg.wParam
- PUSH WM_KEYDOWN
- PUSH EAX
- CALL TControl.Perform
- POP EAX
- DEC [EAX].TControl.fKeyPreviewCount
- @@kp_end:
- {$ENDIF}
-
- {$IFDEF ESC_CLOSE_DIALOGS}
- MOV EAX, EBX
- CALL TControl.ParentForm
- TEST [EAX].TControl.fExStyle, WS_EX_DLGMODALFRAME
- JZ @@ecd_end
- CMP [EDI].TMsg.wParam, 27
- JNE @@ecd_end
- PUSH 0
- PUSH 0
- PUSH WM_CLOSE
- PUSH EAX
- CALL TControl.Perform
- @@ecd_end:
- {$ENDIF}
-
- @@ret0:
- XOR EAX, EAX
- {$IFDEF KEY_PREVIEW}
- JMP @@ret_EAX
- @@chk_other_KEYMSGS:
- MOVZX EAX, word ptr [EDI].TMsg.message
- SUB AX, WM_KEYDOWN
- JB @@ret0
- CMP AX, 6
- JA @@ret0
- // all WM_KEYUP=$101, WM_CHAR=$102, WM_DEADCHAR=$103, WM_SYSKEYDOWN=$104,
- // WM_SYSKEYUP=$105, WM_SYSCHAR=$106, WM_SYSDEADCHAR=$107
- MOV EAX, EBX
- CALL TControl.ParentForm
- CMP EAX, EBX
- JE @@ret0
- MOV [EAX].TControl.fKeyPreviewing, 1
- INC [EAX].TControl.fKeyPreviewCount
- PUSH EAX
- PUSH [EDI].TMsg.lParam
- PUSH [EDI].TMsg.wParam
- PUSH [EDI].TMsg.message
- PUSH EAX
- CALL TControl.Perform
- POP EAX
- DEC [EAX].TControl.fKeyPreviewCount
- XOR EAX, EAX
- {$ENDIF KEY_PREVIEW}
- {$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
-
- @@ret_EAX:
- POP EDI
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcCtrl(Self_: PControl; var Msg: TMsg; var Rslt: Integer): Boolean;
- var F: PControl;
- Cmd : DWORD;
- begin
- Result := FALSE;
- with Self_{-}^{+} do
- case Msg.message of
- CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
- begin
- SetTextColor(Msg.WParam, Color2RGB(fTextColor));
- if fTransparent then
- begin
- SetBkMode( Msg.wParam, Windows.TRANSPARENT );
- Rslt := GetStockObject( NULL_BRUSH );
- end
- else
- begin
- SetBkMode( Msg.wParam, Windows.OPAQUE );
- SetBkColor(Msg.WParam, Color2RGB( fColor ) );
- Rslt := Global_GetCtlBrushHandle( Self_ );
- end;
- Result := TRUE;
- end;
- CM_COMMAND:
- begin
- Result := True;
- Cmd := HiWord( Msg.wParam );
- if Cmd = fCommandActions.aClick then
- begin
- if Integer( fClickDisabled ) <= 0 then
- begin
- Focused := TRUE;
- DoClick;
- end;
- end else
- if Cmd = fCommandActions.aEnter then
- begin
- if Assigned( fOnEnter ) then fOnEnter( Self_ );
- end else
- if Cmd = fCommandActions.aLeave then
- begin
- if Assigned( fOnLeave ) then fOnLeave( Self_ );
- end else
- if Integer(Cmd) = fCommandActions.aChange then
- begin
- if Assigned( fOnChange ) then fOnChange( Self_ );
- end else
- if Integer(Cmd) = fCommandActions.aSelChange then
- begin
- DoSelChange;
- end
- else Result := False;
-
- if Result then
- Rslt := CallDefWndProc( Msg );
-
- end;
-
- WM_SETFOCUS:
- begin
- Rslt := 0;
- Result := TRUE;
- F := ParentForm;
- if F <> nil then
- begin
- if (F.fCurrentControl <> nil) and (F.fCurrentControl <> Self_) and
- Assigned( F.fCurrentControl.fLeave ) then
- F.fCurrentControl.fLeave( F.fCurrentControl );
- F.fCurrentControl := Self_;
- Result := False; // go further handling
- end;
- end;
- {$IFDEF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- WM_KEYDOWN:
- begin
- {$IFDEF KEY_PREVIEW}
- //--------------------------------Truf-------------------------------------
- if ParentForm <> Self_ then
- begin
- if ParentForm.KeyPreview then begin
- ParentForm.KeyPreviewing := TRUE;
- inc( ParentForm.FKeyPreviewCount );
- ParentForm.Perform(WM_KEYDOWN,msg.wParam,msg.lParam);
- dec( ParentForm.FKeyPreviewCount );
- end;
- end;
- //--------------------------------Truf-------------------------------------
- {$ENDIF KEY_PREVIEW}
- {$IFDEF ESC_CLOSE_DIALOGS}
- //---------------------------------Babenko Alexey--------------------------
- begin
- if (Self_.ParentForm.fExStyle and WS_EX_DLGMODALFRAME) <> 0 then
- if Msg.wParam = 27 then
- Self_.ParentForm.Perform(WM_CLOSE, 0, 0);
- end;
- //---------------------------------Babenko Alexey--------------------------
- {$ENDIF ESC_CLOSE_DIALOGS}
- end;
- {$IFDEF KEY_PREVIEW}
- WM_SYSKEYDOWN,
- WM_KEYUP, WM_SYSKEYUP,
- WM_CHAR, WM_SYSCHAR:
- if ParentForm <> Self_ then
- begin
- if ParentForm.KeyPreview then
- begin
- ParentForm.KeyPreviewing := TRUE;
- ParentForm.Perform(Msg.message,msg.wParam,msg.lParam);
- end;
- end;
- {$ENDIF KEY_PREVIEW}
- {$ENDIF KEY_PREVIEW_OR_ESC_CLOSE_DIALOGS}
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcCtrl]
-
- {$ifdef win32}
- //[FUNCTION WndProcTransparent]
- {$IFDEF OLD_TRANSPARENT}
- function WndProcTransparent( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
- var DC, PDC, BLTDC: HDC;
- Save: integer;
- OLDp: THANDLE;
- L, T: SmallInt;
- TP, ParentClient: TPoint;
- TR, Margins: TRect;
- Wnd: HWND;
- tRgn: HRgn;
- C: PControl;
- begin
- Result := FALSE;
- {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
- if AppletTerminated or not Sender.ToBeVisible then
- begin
- Exit;
- end;
- {$ENDIF}
-
- case Msg.message of
- WM_HSCROLL, WM_VSCROLL:
- begin
- Sender.Invalidate;
- exit;
- end;
- WM_SETTEXT:
- begin
- if Sender.fIsStaticControl = 0 then exit;
- Sender.Invalidate;
- Rslt := DefWindowProc
- ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam );
- Result := TRUE;
- exit;
- end;
- WM_NCPAINT:
- begin
- if Sender.fTransparent then
- Result := TRUE;
- exit;
- end;
- end;
-
- if Sender.fTransparent and (not Sender.fParent.fDoubleBuffered) then
- Sender.fTransparent := FALSE;
- if not (Sender.fTransparent or Sender.fDoubleBuffered) then exit;
- if Sender.fSelfRequirePaint then exit;
-
- case Msg.message of
- WM_ERASEBKGND:
- begin
- Result := TRUE;
- end;
- WM_PAINT:
- begin
- ValidateRect(Sender.fHandle, nil); //???--brandys???
- if (Sender.fTransparent) and (not Sender.fParentRequirePaint) then begin
- InvalidateRect(Sender.fParent.Handle, nil, FALSE);
- Result := TRUE;
- exit;
- end;
-
- GetClientRect(Msg.hwnd, Margins);
- OLDp := 0;
- if not Sender.fParentRequirePaint then begin
- Sender.fDblExcludeRgn := CreateRectRgn(0, 0, Margins.Right, Margins.Bottom);
- DC := GetDC(0);
- PDC := CreateCompatibleDC( DC );
- OLDp := SelectObject(PDC,
- CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) );
- ReleaseDC(0, DC);
- Sender.fParentCoordX := 0;
- Sender.fParentCoordy := 0;
- end else begin
- PDC := Msg.wParam;
- Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn;
- end;
-
- Sender.fSelfRequirePaint := TRUE;
- Sender.fPaintDC := PDC;
- if (not Sender.fParentRequirePaint) or Sender.fDoubleBuffered then
- Sender.Perform(WM_ERASEBKGND, PDC, 0);
- Sender.Perform(WM_PAINT, PDC, 0);
-
- Wnd := GetWindow( Sender.fHandle, GW_CHILD );
- Wnd := GetWindow( Wnd, GW_HWNDLAST);
- while Wnd <> 0 do begin
- if IsWindowVisible(Wnd) then begin
- {$IFDEF USE_PROP}
- C := Pointer( GetProp( Wnd, ID_SELF ) );
- {$ELSE}
- C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
- {$ENDIF}
- with C{-}^{+} do begin
- if (C <> nil) and (fTransparent or fDoubleBuffered) then begin
- Save := SaveDC( PDC );
- fParentRequirePaint := TRUE;
-
- L := Sender.fParentCoordX + Left;
- T := Sender.fParentCoordY + Top;
- SetWindowOrgEx(PDC, -L, -T, nil);
- SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT);
- TP.x := 0; TP.Y := 0;
- ClientToScreen(fHandle, TP);
- GetWindowRect(fHandle, TR);
- fParentCoordX := L + TP.X - TR.Left;
- fParentCoordY := T + TP.Y - TR.Top;
- SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil);
- GetClientRect(Wnd, TR);
- IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom);
- SendMessage(Wnd, WM_PAINT, PDC, 0);
-
- fParentRequirePaint := FALSE;
- RestoreDC( PDC, Save );
- end else begin
- GetWindowRect(Wnd, TR);
- TP.X := 0; TP.Y := 0;
- ClientToScreen(Sender.fHandle, TP);
- TP.X := TR.Left - TP.X + Sender.fParentCoordX;
- TP.Y := TR.Top - TP.Y + Sender.fParentCoordY;
- TR.Left := TR.Right - TR.Left;
- TR.Top := TR.Bottom - TR.Top;
-
- tRgn := CreateRectRgn(TP.X, TP.Y, TP.X+TR.Left, TP.Y+TR.Top);
- CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, tRgn, RGN_DIFF);
- DeleteObject(tRgn);
- end;
- end;
- end;
- Wnd := GetWindow( Wnd, GW_HWNDPREV );
- end;
- Sender.fPaintDC := 0;
- Sender.fSelfRequirePaint := FALSE;
-
- if not Sender.fParentRequirePaint then begin
- BLTDC := GetWindowDC(Sender.fHandle);
- GetWindowRect( Sender.fHandle, TR );
- ParentClient.x := 0; ParentClient.y := 0;
- ClientToScreen( Sender.fHandle, ParentClient );
- SetWindowOrgEx(BLTDC, TR.Left - ParentClient.x, TR.Top - ParentClient.y, nil);
- OffsetRgn(Sender.fDblExcludeRgn, ParentClient.x - TR.Left, ParentClient.y - TR.Top);
- ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND);
-
- BitBlt( BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY );
- ReleaseDC(Sender.fHandle, BLTDC);
- DeleteObject(SelectObject( PDC, OLDp ));
- DeleteObject(Sender.fDblExcludeRgn);
- DeleteDC( PDC );
- end;
-
- //ValidateRect(Sender.fHandle, nil); //???++brandys???//
- Result := TRUE;
- end;
- end;
- end;
- {$ELSE NEW_TRANSPARENT} // by Alexander Karpinsky a.k.a. homm
- function WndProcTransparent( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
-
- function SetRectRgnInderect(tRgn: HRGN; const TR: TRect): BOOL;
- begin
- Result := SetRectRgn(tRgn, TR.Left, TR.Top, TR.Right, TR.Bottom);
- end;
-
- var
- DC, PDC, BLTDC: HDC;
- Save: integer;
- OLDp: THANDLE;
- L, T: SmallInt;
- TP: TPoint;
- TR, Margins: TRect;
- Wnd: HWND;
- C: PControl;
- ChildRgn: HRGN;
- PS: TPaintStruct;
-
- begin
- Result := FALSE;
-
- {$IFDEF STOP_WNDPROCTRANSPARENT_AFTER_APPLETTERMINATED}
- if AppletTerminated or not Sender.ToBeVisible then
- begin
- Exit;
- end;
- {$ENDIF}
-
- if Sender.fTransparent and (not Sender.fParent.fDoubleBuffered) then
- Sender.fTransparent := FALSE;
- if not (Sender.fTransparent or Sender.fDoubleBuffered) then exit;
-
- case Msg.message of
- WM_HSCROLL, WM_VSCROLL:
- begin
- Sender.Invalidate;
- exit;
- end;
- WM_SETTEXT:
- begin
- if Sender.fIsStaticControl = 0 then exit;
- Sender.Invalidate;
- Rslt := DefWindowProc ( Sender.fHandle, WM_SETTEXT, Msg.wParam, Msg.lParam );
- Result := TRUE;
- exit;
- end;
- WM_PAINT,
- WM_ERASEBKGND:;
- WM_NCPAINT:
- if not Sender.fTransparent then
- exit;
- else exit;
- end;
-
- if Sender.fSelfRequirePaint then begin
- exit;
- end;
-
- Result := TRUE;
-
-
- if Sender.fTransparent and (not Sender.fParentRequirePaint) then
- begin
- TR := Sender.BoundsRect;
- InvalidateRect(Sender.fParent.fHandle, @TR, true);
- ValidateRect(Sender.fHandle, nil); //???--brandys???+
- exit;
- end;
-
- if Msg.message = WM_PAINT then begin
- OLDp := 0;
- if not Sender.fParentRequirePaint then begin
- Sender.fDblExcludeRgn := CreateRectRgn(0, 0, 0, 0);
- if GetUpdateRgn(Sender.fHandle, Sender.fDblExcludeRgn, TRUE) <= NULLREGION then
- begin
- DeleteObject(Sender.fDblExcludeRgn);
- exit;
- end;
-
- DC := BeginPaint(Sender.fHandle, PS);
- PDC := CreateCompatibleDC( DC );
- GetClientRect(Msg.hwnd, Margins);
- OLDp := SelectObject(PDC, CreateCompatibleBitmap(DC, Margins.Right, Margins.Bottom) );
- Sender.fParentCoordX := 0;
- Sender.fParentCoordy := 0;
- end else begin
- PDC := Msg.wParam;
- Sender.fDblExcludeRgn := Sender.fParent.fDblExcludeRgn;
- end;
-
- Sender.fSelfRequirePaint := TRUE;
- Sender.fPaintDC := PDC;
- if (not Sender.fParentRequirePaint) or Sender.fDoubleBuffered then
- Sender.Perform(WM_ERASEBKGND, PDC, 0);
- Sender.Perform(WM_PAINT, PDC, 0);
-
-
- Wnd := GetWindow( Sender.fHandle, GW_CHILD );
- Wnd := GetWindow( Wnd, GW_HWNDLAST);
- while Wnd <> 0 do begin
- if IsWindowVisible(Wnd) then begin
- ChildRgn := CreateRectRgn(0, 0, 0, 0);
- if GetWindowRgn(WND, ChildRgn) <= NULLREGION then begin
- GetWindowRect(WND, TR);
- TP.X := 0; TP.Y := 0;
- ClientToScreen(Sender.fHandle, TP);
- OffsetRect(TR, -TP.X , -TP.Y);
- SetRectRgnInderect(ChildRgn, TR);
- end;
- OffsetRgn(ChildRgn, Sender.fParentCoordX, Sender.fParentCoordY);
-
- {$IFDEF USE_PROP}
- C := Pointer( GetProp( Wnd, ID_SELF ) );
- {$ELSE}
- C := Pointer( GetWindowLong( Wnd, GWL_USERDATA ) );
- {$ENDIF}
- if CombineRgn(ChildRgn, ChildRgn, Sender.fDblExcludeRgn, RGN_AND) >= SIMPLEREGION then begin
- with C{-}^{+} do begin
- if (C <> nil) and fTransparent then begin
- Save := SaveDC( PDC );
- fParentRequirePaint := TRUE;
-
- L := Sender.fParentCoordX + Left;
- T := Sender.fParentCoordY + Top;
- SetWindowOrgEx(PDC, -L, -T, nil);
- SendMessage(Wnd, WM_PRINT, PDC, PRF_NONCLIENT);
- TP.x := 0; TP.Y := 0;
- ClientToScreen(fHandle, TP);
- GetWindowRect(fHandle, TR);
- fParentCoordX := L + TP.X - TR.Left;
- fParentCoordY := T + TP.Y - TR.Top;
- SetWindowOrgEx(PDC, -fParentCoordX, -fParentCoordY, nil);
- GetClientRect(Wnd, TR);
- IntersectClipRect(PDC, 0, 0, TR.Right, TR.Bottom);
- SendMessage(Wnd, WM_PAINT, PDC, 0);
-
- fParentRequirePaint := FALSE;
- RestoreDC( PDC, Save );
- end else begin
- CombineRgn(Sender.fDblExcludeRgn, Sender.fDblExcludeRgn, ChildRgn, RGN_DIFF);
- end;
- end;
- end; // if Save >= SIMPLEREGION then begin
- DeleteObject(ChildRgn);
- end;
- Wnd := GetWindow( Wnd, GW_HWNDPREV );
- end;
- Sender.fPaintDC := 0;
- Sender.fSelfRequirePaint := FALSE;
-
- if not Sender.fParentRequirePaint then begin
- BLTDC := GetDCEx(Sender.fHandle, 0, DCX_CACHE or DCX_CLIPSIBLINGS);
- ExtSelectClipRgn(BLTDC, Sender.fDblExcludeRgn, RGN_AND);
-
- BitBlt(BLTDC, 0, 0, Margins.Right, Margins.Bottom, PDC, 0, 0, SRCCOPY );
-
- ReleaseDC(Sender.fHandle, BLTDC);
- DeleteObject(SelectObject( PDC, OLDp ));
- DeleteObject(Sender.fDblExcludeRgn);
- DeleteDC( PDC );
- EndPaint(Sender.fHandle, PS);
- end;
- end;
- end;
- {$ENDIF}
- //[END WndProcTransparent]
- {$endif win32}
-
- //[FUNCTION WndProcPaint]
- {$IFDEF ASM_noVERSION}
- function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- const szPaintStruct = sizeof(TPaintStruct);
- asm
- CMP word ptr [EDX].TMsg.message, WM_PRINT
- JE @@print
- CMP word ptr [EDX].TMsg.message, WM_PAINT
- JNE @@ret_false
- @@print:
- CMP word ptr [EAX].TControl.fOnPaint.TMethod.Code+2, 0
- JE @@ret_false
- PUSH EBX
- PUSH ESI
-
- XCHG EBX, EAX
- MOV ESI, EDX
- XOR EAX, EAX
- PUSH ECX
- PUSH EAX
- PUSH EAX
- PUSH EAX
- PUSH EAX
- CALL CreateRectRgn
- MOV [EBX].TControl.fUpdRgn, EAX
-
- MOVSX EDX, [EBX].TControl.fEraseUpdRgn
- PUSH EDX
- PUSH EAX
- PUSH [EBX].TControl.fHandle
- CALL GetUpdateRgn
-
- CMP EAX, 1
- JA @@collectUpdRgn
-
- XOR EAX, EAX
- XCHG EAX, [EBX].TControl.fUpdRgn
- PUSH EAX
- CALL DeleteObject
-
- @@collectUpdRgn:
- MOV ECX, [EBX].TControl.fCollectUpdRgn
- JECXZ @@asg_fPaintDC
- XCHG EAX, ECX
- MOV ECX, [EBX].TControl.fUpdRgn
- JECXZ @@asg_fPaintDC
-
- PUSH RGN_OR
- PUSH ECX
- PUSH EAX
- PUSH EAX
- CALL CombineRgn
-
- DEC EAX
- JNZ @@invalidateRgn
-
- ADD ESP, -16
- PUSH ESP
- PUSH [EBX].TControl.fHandle
- CALL Windows.GetClientRect
-
- PUSH [EBX].TControl.fCollectUpdRgn
- CALL DeleteObject
- CALL CreateRectRgn
- MOV [EBX].TControl.fCollectUpdRgn, EAX
-
- @@invalidateRgn:
- MOVSX EDX, [EBX].TControl.fEraseUpdRgn
- PUSH EDX
- PUSH [EBX].TControl.fCollectUpdRgn
- PUSH [EBX].TControl.fHandle
- CALL InvalidateRgn
-
- @@asg_fPaintDC:
- MOV ECX, [ESI].TMsg.wParam
- INC ECX
- LOOP @@storePaintDC
-
- ADD ESP, -szPaintStruct
- PUSH ESP
- PUSH [EBX].TControl.fHandle
- CALL BeginPaint
- XCHG ECX, EAX
- @@storePaintDC:
- MOV [EBX].TControl.fPaintDC, ECX
- XCHG EAX, ECX
-
- MOV ECX, [EBX].TControl.fCollectUpdRgn
- JECXZ @@doOnPaint
-
- PUSH ECX
- PUSH EAX
- CALL SelectClipRgn
-
- @@doOnPaint:
- MOV ECX, [EBX].TControl.fPaintDC
- MOV EDX, EBX
-
- MOV EAX, [EBX].TControl.fOnPaint.TMethod.Data
- CALL dword ptr [EBX].TControl.fOnPaint.TMethod.Code
-
- MOV ECX, [EBX].TControl.fCanvas
- JECXZ @@e_paint
-
- XCHG EAX, ECX
- XOR EDX, EDX
- CALL TCanvas.SetHandle
-
- @@e_paint:
- MOV ECX, [ESI].TMsg.wParam
- INC ECX
- LOOP @@zero_fPaintDC
-
- PUSH ESP
- PUSH [EBX].TControl.fHandle
- CALL EndPaint
- ADD ESP, szPaintStruct
-
- @@zero_fPaintDC:
- XOR ECX, ECX
- MOV [EBX].TControl.fPaintDC, ECX
-
- POP EAX
- MOV [EAX], ECX
-
- XCHG ECX, [EBX].TControl.fUpdRgn
- JECXZ @@exit_True
-
- PUSH ECX
- CALL DeleteObject
-
- @@exit_True:
- POP ESI
- POP EBX
- MOV AL, 1
- RET
-
- @@ret_false:
- XOR EAX, EAX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcPaint( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var PaintStruct: TPaintStruct;
- Cplxity: Integer;
- OldPaintDC: HDC;
- begin
- with Self_{-}^{+} do
- case Msg.message of
- //WM_PRINT,
- WM_PAINT: if assigned( fOnPaint ) {or Assigned( fPaintProc )} then
- begin
- fUpdRgn := CreateRectRgn( 0, 0, 0, 0 );
- Cplxity := Integer( GetUpdateRgn( fHandle, fUpdRgn, fEraseUpdRgn ) );
- if (Cplxity = NULLREGION) or (Cplxity = ERROR) then
- begin
- DeleteObject( fUpdRgn );
- fUpdRgn := 0;
- end;
-
- OldPaintDC := fPaintDC;
- fPaintDC := Msg.wParam;
- if fPaintDC = 0 then
- fPaintDC := BeginPaint( fHandle, PaintStruct );
-
- //if fUpdRgn <> 0 then added in v2.16
- // SelectClipRgn( fPaintDC, fUpdRgn ); removed in v2.26
-
- fOnPaint( Self_, fPaintDC );
-
- if assigned( Self_.fCanvas ) then
- Self_.fCanvas.SetHandle( 0 );
-
- if Msg.wParam = 0 then
- EndPaint( fHandle, PaintStruct );
- fPaintDC := OldPaintDC;
-
- Rslt := 0;
-
- Result := True;
- if fUpdRgn <> 0 then
- DeleteObject( fUpdRgn );
- fUpdRgn := 0;
- Exit;
- end;
- end;
- Result := FALSE;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcPaint]
-
- {$ENDIF WIN_GDI}
- //[procedure TControl.SetOnPaint]
- {$IFDEF GDI}
- procedure TControl.SetOnPaint( const Value: TOnPaint );
- begin
- fOnPaint := Value;
- AttachProc( WndProcPaint );
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function expose_widget( Widget: PGtkWidget; Event: PGdkEventExpose;
- Sender: PControl ): Boolean; cdecl;
- begin
- if not Assigned( Sender.fOnPaint ) then Result := FALSE
- else
- begin
- Sender.Canvas.SaveState;
- Sender.fOnPaint( Sender, Sender.Canvas.Handle );
- Sender.Canvas.RestoreState;
- Result := TRUE;
- end;
- end;
-
- procedure TControl.SetOnPaint( const Value: TOnPaint );
- begin
- fOnPaint := Value;
- {$IFNDEF SMALLER_CODE} // it is actually not necessary to disconnect, event
- // still will be fired but fOnPaint is not assigned
- // so FALSE will be returned to GTK.
- if not Assigned( Value ) then
- gtk_signal_disconnect( fHandle, fExposeEvent )
- else
- {$ENDIF}
- fExposeEvent := gtk_signal_connect( GTK_OBJECT( fHandle ), 'expose_event',
- @ expose_widget, @ Self );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //*
- //[function WndProcEraseBkgnd]
- function WndProcEraseBkgnd( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var PaintStruct: TPaintStruct;
- OldPaintDC: HDC;
- begin
- Result := FALSE;
- if Msg.message = WM_ERASEBKGND then
- begin
- if Assigned( Sender.OnEraseBkgnd ) then
- begin
- OldPaintDC := Sender.fPaintDC;
- Sender.fPaintDC := Msg.wParam;
- if Sender.fPaintDC = 0 then
- Sender.fPaintDC := BeginPaint( Sender.fHandle, PaintStruct );
- Sender.OnEraseBkgnd( Sender, Msg.wParam );
- if Msg.wParam = 0 then
- EndPaint( Sender.fHandle, PaintStruct );
- if Assigned( Sender.fCanvas ) then
- Sender.fCanvas.SetHandle( 0 );
- Sender.fPaintDC := OldPaintDC;
- Rslt := 0;
- Result := TRUE;
- end
- else
- Rslt := 0;
- end;
- end;
-
- //[procedure TControl.SetOnEraseBkgnd]
- procedure TControl.SetOnEraseBkgnd(const Value: TOnPaint);
- begin
- fOnEraseBkgnd := Value;
- AttachProc( WndProcEraseBkgnd );
- end;
-
- procedure DummyPaintClear( Self_: PControl; Sender: PControl; DC: HDC );
- begin
- Sender.Canvas.FillRect( Sender.ClientRect );
- end;
-
- {$IFDEF NEW_GRADIENT}
- function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var PaintStruct: TPaintStruct;
- Bmp: PBitmap;
- CR: TRect;
- I: Integer;
- R, G, B: Integer;
- R1, G1, B1: Integer;
- C: TColor;
- W, H, WH: Integer;
- OldPaintDC: HDC;
- Pattern: PBitmap;
- pdc: HDC;
- pw: integer;
-
- begin
- case Msg.message of
- WM_PAINT, WM_PRINTCLIENT:
- begin
- result := false;
- CR := Self_.ClientRect;
- case Self_.fGradientStyle of
- gsHorizontal: begin
- W := CR.Right;
- H := 1;
- WH := W;
- pw := 32;
- end;
- gsVertical: begin
- W := 1;
- H := CR.Bottom;
- WH := H;
- pw := 32
- end;
- gsTopToBottom,
- gsBottomToTop: begin
- W := CR.Bottom + CR.Right;
- H := 1;
- WH := W;
- pw := 1 + (CR.Bottom div 16);
- if pw > 6 then
- pw := 6;
- end;
- else exit;
- // <-- impartant if user change GradientStyle to not supported by this object
- end;
- OldPaintDC := Self_.fPaintDC;
- Self_.fPaintDC := Msg.wParam;
- if Self_.fPaintDC = 0 then
- Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
- Bmp := NewDIBBitmap( W, H, pf24bit );
- C := Color2RGB( Self_.fColor1 );
- R := C shr 16;
- G := (C shr 8) and $FF;
- B := C and $FF;
- C := Color2RGB( Self_.fColor2 );
- R1 := C shr 16;
- G1 := (C shr 8) and $FF;
- B1 := C and $FF;
- for I := 0 to WH-1 do begin
- C := (( R + (R1 - R) * I div WH ) shl 16) or
- (( G + (G1 - G) * I div WH ) shl 8) or
- ( B + (B1 - B) * I div WH );
- if Self_.fGradientStyle = gsVertical then
- Bmp.DIBPixels[ 0, I ] := C
- else
- Bmp.DIBPixels[ I, 0 ] := C;
- end;
- if Self_.fGradientStyle = gsVertical then
- Pattern := NewBitMap(pw, H)
- else
- Pattern := NewBitMap(W, pw);
- pdc := Pattern.Canvas.Handle;
- SetStretchBltMode( pdc, HALFTONE);
- SetBrushOrgEx( pdc, 0, 0, nil );
- StretchBlt( pdc, 0, 0, Pattern.Width, Pattern.Height, Bmp.Canvas.Handle,
- 0, 0, W, H, SRCCOPY );
-
- case Self_.fGradientStyle of
- gsHorizontal: for i := 0 to (CR.Bottom div pw) do
- Pattern.Draw(Self_.fPaintDC, 0, i*pw);
- gsVertical: for i := 0 to (CR.Right div pw) do
- Pattern.Draw(Self_.fPaintDC, i*pw, 0);
- gsTopToBottom: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
- Pattern.Draw(Self_.fPaintDC, -i*pw, i*pw);
- gsBottomToTop: for i := 0 to ((CR.Bottom + pw -1) div pw)-1 do
- Pattern.Draw(Self_.fPaintDC, -CR.Bottom + i*pw, i*pw);
- end;
- Bmp.Free;
- Pattern.Free;
-
- if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
- Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
- if Assigned( Self_.fOnPaint ) then
- Self_.fOnPaint( Self_, Self_.fPaintDC );
-
- if Msg.wParam = 0 then
- EndPaint( Self_.fHandle, PaintStruct );
- Self_.fPaintDC := OldPaintDC;
- Rslt := 0;
- Result := True;
- Exit;
- end;
- end;
- Result := False;
- end;
- {$ELSE OLD_GRADIENT}
- function WndProcGradient( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var PaintStruct: TPaintStruct;
- CR: TRect;
- I, R, G, B, R1, G1, B1, W, H, WH: Integer;
- C: TColor;
- {$ifdef win32}
- W9x: Boolean;
- Bmp: PBitmap;
- {$endif win32}
- Br: HBrush;
- OldPaintDC: HDC;
- begin
- case Msg.message of
- WM_PAINT, WM_PRINTCLIENT:
- begin
- OldPaintDC := Self_.fPaintDC;
- Self_.fPaintDC := Msg.wParam;
- if Self_.fPaintDC = 0 then
- Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
- CR := Self_.ClientRect;
- {$ifdef win32}
- W9x := WinVer < wvNT;
- Bmp := nil;
- {$endif win32}
- W := 1;
- H := CR.Bottom;
- WH := H;
- if Self_.fGradientStyle = gsHorizontal then
- begin
- W := CR.Right;
- H := 1;
- WH := W;
- end;
- {$ifdef win32}
- if not W9x then
- Bmp := NewDIBBitmap( W, H, pf32bit );
- {$endif win32}
- C := Color2RGB( Self_.fColor1 );
- R := C shr 16;
- G := (C shr 8) and $FF;
- B := C and $FF;
- C := Color2RGB( Self_.fColor2 );
- R1 := C shr 16;
- G1 := (C shr 8) and $FF;
- B1 := C and $FF;
- for I := 0 to WH-1 do
- begin
- C := ((( R + (R1 - R) * I div WH ) and $FF) shl 16) or
- ((( G + (G1 - G) * I div WH ) and $FF) shl 8) or
- ( B + (B1 - B) * I div WH ) and $FF;
- {$ifdef win32}
- if W9x then
- {$endif win32}
- begin
- if Self_.fGradientStyle <> gsHorizontal then
- CR.Bottom := CR.Top + 1
- else
- CR.Right := CR.Left + 1;
- Br := CreateSolidBrush( C );
- Windows.FillRect( Self_.fPaintDC, CR, Br );
- DeleteObject( Br );
- if Self_.fGradientStyle <> gsHorizontal then
- Inc( CR.Top )
- else
- Inc( CR.Left );
- end
- {$ifdef win32}
- else
- begin
- if Self_.fGradientStyle <> gsHorizontal then
- Bmp.DIBPixels[ 0, I ] := C
- else
- Bmp.DIBPixels[ I, 0 ] := C;
- end;
- {$endif win32}
- end;
- {$ifdef win32}
- if not W9x then
- begin
- SetStretchBltMode( Self_.fPaintDC, HALFTONE );
- SetBrushOrgEx( Self_.fPaintDC, 0, 0, nil );
- StretchBlt( Self_.fPaintDC, 0, 0, CR.Right, CR.Bottom, Bmp.Canvas.Handle,
- 0, 0, W, H, SRCCOPY );
- Bmp.Free;
- end;
- {$endif win32}
- if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
- Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
- if Assigned( Self_.fOnPaint ) then
- Self_.fOnPaint( Self_, Self_.fPaintDC );
-
- if Msg.wParam = 0 then
- EndPaint( Self_.fHandle, PaintStruct );
- Self_.fPaintDC := OldPaintDC;
- Rslt := 0;
- Result := True;
- Exit;
- end;
- end;
- Result := False;
- end;
- {$ENDIF OLD_GRADIENT}
- //[END WndProcGradient]
-
- //[function WndProcGradientEx]
- function WndProcGradientEx( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- function Ceil( X: Double ): Integer;
- begin
- Result := Round( X ) {+ 1};
- //if X > 0 then dec( Result ) else inc( Result );
- end;
- const
- SQRT2 = 1.4142135623730950488016887242097;
- var
- RC, R0: TRect;
- C, C2: TColor;
- R1, G1, B1: Integer;
- R2, G2, B2: Integer;
- DX1, DX2, DY1, DY2, DR, DG, DB, K: Double;
- PaintStruct: TPaintStruct;
- I: Integer;
- Br: HBrush;
- Rgn: HRgn;
- {$ifdef win32}
- Poly: array[ 0..3 ] of TPoint;
- {$endif win32}
- OldPaintDC: HDC;
- fX1, fX2, fY1, fY2: Double;
-
- procedure OffsetF( DX, DY: Double );
- begin
- fX1 := fX1 + DX;
- fX2 := fX2 + DX;
- fY1 := fY1 + DY;
- fY2 := fY2 + DY;
- end;
- begin
- Result := FALSE;
- if (Msg.message <> WM_PAINT) and (Msg.message <> WM_PRINTCLIENT) then Exit;
- if Self_.fGradientStyle in [ gsHorizontal, gsVertical ] then
- begin
- Result := WndProcGradient( Self_, Msg, Rslt );
- Exit;
- end;
- C := Color2RGB( Self_.fColor2 );
- R2 := C and $FF;
- G2 := (C shr 8) and $FF;
- B2 := (C shr 16) and $FF;
- C := Color2RGB( Self_.fColor1 );
- R1 := C and $FF;
- G1 := (C shr 8) and $FF;
- B1 := (C shr 16) and $FF;
- DR := (R2 - R1) / 256;
- DG := (G2 - G1) / 256;
- DB := (B2 - B1) / 256;
- OldPaintDC := Self_.fPaintDC;
- Self_.fPaintDC := Msg.wParam;
- if Self_.fPaintDC = 0 then
- Self_.fPaintDC := BeginPaint( Self_.fHandle, PaintStruct );
- RC := Self_.ClientRect;
- fX1 := 0;
- fY1 := 0;
- case Self_.fGradientStyle of
- gsRombic:
- begin
- fX2 := RC.Right / 128;
- fY2 := RC.Bottom / 128;
- end;
- gsElliptic:
- begin
- fX2 := RC.Right / 256 * SQRT2;
- fY2 := RC.Bottom / 256 * SQRT2;
- end;
- else
- begin
- fX2 := RC.Right / 256;
- fY2 := RC.Bottom / 256;
- end;
- end;
- case Self_.fGradientStyle of
- gsRectangle, gsRombic, gsElliptic:
- begin
- case Self_.FGradientLayout of
- glCenter, glTop, glBottom:
- OffsetF( (RC.Right - fX2) / 2, 0 );
- glTopRight, glBottomRight, glRight:
- OffsetF( RC.Right - fX2 / 2, 0 );
- glTopLeft, glBottomLeft, glLeft:
- OffsetF( -fX2 / 2, 0 );
- end;
- case Self_.FGradientLayout of
- glCenter, glLeft, glRight:
- OffsetF( 0, (RC.Bottom - fY2) / 2 );
- glBottom, glBottomLeft, glBottomRight:
- OffsetF( 0, RC.Bottom - fY2 / 2 );
- glTop, glTopLeft, glTopRight:
- OffsetF( 0, -fY2 / 2 )
- end;
- end;
- end;
- DX1 := -fX1 / 255; //(-RF.Left) / 255;
- DY1 := -fY1 / 255; // (-RF.Top) / 255;
- DX2 := (RC.Right - fX2) / 255; //(RC.Right - RF.Right) / 255;
- DY2 := (RC.Bottom - fY2) / 255;
- case Self_.fGradientStyle of
- gsRombic, gsElliptic:
- begin
- if DX2 < -DX1 then DX2 := -DX1;
- if DY2 < -DY1 then DY2 := -DY1;
- K := 2;
- if Self_.fGradientStyle = gsElliptic then K := SQRT2;
- DX2 := DX2 * K;
- DY2 := DY2 * K;
- DX1 := -DX2;
- DY1 := -DY2;
- end;
- end;
- C2 := C;
- for I := 0 to 255 do
- begin
- if (I < 255) then
- begin
- C2 := TColor( (( Ceil( B1 + DB * (I+1) ) and $FF) shl 16) or
- (( Ceil( G1 + DG * (I+1) ) and $FF) shl 8) or
- Ceil( R1 + DR * (I+1) ) and $FF );
- if (Self_.fGradientStyle in [gsRombic,gsElliptic,gsRectangle]) and
- (C2 = C) then continue;
- end;
- Br := CreateSolidBrush( C );
- R0 := MakeRect( Ceil( fX1 + DX1 * I ),
- Ceil( fY1 + DY1 * I ),
- Ceil( fX2 + DX2 * I ) + 1,
- Ceil( fY2 + DY2 * I ) + 1 );
- Rgn := 0;
- {$ifdef wince}
- Rgn := CreateRectRgnIndirect( R0 );
- {$else}
- case Self_.fGradientStyle of
- gsRectangle:
- Rgn := CreateRectRgnIndirect( R0 );
- gsRombic:
- begin
- Poly[ 0 ].x := R0.Left;
- Poly[ 0 ].y := R0.Top + (R0.Bottom - R0.Top) div 2;
- Poly[ 1 ].x := R0.Left + (R0.Right - R0.Left) div 2;
- Poly[ 1 ].y := R0.Top;
- Poly[ 2 ].x := R0.Right;
- Poly[ 2 ].y := Poly[ 0 ].y;
- Poly[ 3 ].x := Poly[ 1 ].x;
- Poly[ 3 ].y := R0.Bottom;
- Rgn := CreatePolygonRgn( Poly[ 0 ].x, 4, ALTERNATE );
- end;
- gsElliptic:
- Rgn := CreateEllipticRgnIndirect( R0 );
- end;
- {$endif wince}
- if Rgn <> 0 then
- begin
- if Rgn <> NULLREGION then
- begin
- Windows.FillRgn( Self_.fPaintDC, Rgn, Br );
- {$ifdef win32}
- ExtSelectClipRgn( Self_.fPaintDC, Rgn, RGN_DIFF );
- {$endif win32}
- end;
- DeleteObject( Rgn );
- end;
- DeleteObject( Br );
- C := C2;
- end;
- if TMethod( Self_.fOnPaint2 ).Code = @ DummyPaintClear then
- Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintProc ) );
- if Assigned( Self_.fOnPaint ) then
- Self_.fOnPaint( Self_, Self_.fPaintDC );
- if Self_.fPaintDC <> HDC( Msg.wParam ) then
- EndPaint( Self_.fHandle, PaintStruct );
- Self_.fPaintDC := OldPaintDC;
- Rslt := 0;
- Result := True;
- end;
-
- //*
- //[function WndProcLabelEffect]
- function WndProcLabelEffect( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var
- Sz: TSize;
- P0: TPoint;
- CR: TRect;
- B : Boolean;
- CShadow: TColor;
- Target: PCanvas;
- Txt: KOLString;
- //LCaption: PKOLChar;
- OldPaintDC: HDC;
-
- procedure doTextOut( shfx, shfy: Integer; col: TColor );
- begin
- SetTextColor( Target.fHandle, col );
- Windows.
- {$IFDEF UNICODE_CTRLS}
- ExtTextOutW
- {$ELSE}
- ExtTextOut
- {$ENDIF}
- ( Target.fHandle, P0.x + shfx, P0.y + shfy,
- ETO_CLIPPED, @CR,
- PKOLChar(Txt), Length(Txt), nil );
- //GDIFlush; // for test only
- end;
-
- var I, J, Istp : Integer;
- PS: TPaintStruct;
- //DoEndPaint: Boolean;
- begin
- Result := False;
-
- case Msg.message of
-
- WM_SETTEXT:
- begin
- Self_.fCaption := PKOLChar( Msg.lParam );
- Result := True;
- Rslt := 1;
- Exit;
- end;
-
- WM_PRINTCLIENT, WM_PAINT:
- begin
- OldPaintDC := Self_.fPaintDC;
- Self_.fPaintDC := Msg.wParam;
- if Self_.fPaintDC = 0 then
- Self_.fPaintDC := BeginPaint( Self_.fHandle, PS );
- begin
- Target := Self_.Canvas;
- Txt := Self_.fCaption;
- Target.TextArea( Txt, Sz, P0 );
- if Self_.fShadowDeep <> 0 then
- begin
- for B := False to Self_.fCtl3D do
- begin
- Inc( Sz.cx, Abs( Self_.fShadowDeep ) );
- Inc( Sz.cy, Abs( Self_.fShadowDeep ) );
- end;
- end;
- CR := Self_.ClientRect;
- case Self_.fTextAlign of
- taCenter: P0.x := P0.x + (CR.Right - Sz.cx) div 2;
- taRight: P0.x := P0.x + (CR.Right - Sz.cx);
- end;
- case Self_.fVerticalAlign of
- vaCenter: P0.y := P0.y + (CR.Bottom - Sz.cy) div 2;
- vaBottom: P0.y := P0.y + (CR.Bottom - Sz.cy);
- end;
- if Self_.fShadowDeep <> 0 then
- begin
- if Self_.fColor2 = clNone then
- CShadow := ColorsMix(Color2RGB(Self_.fTextColor),Color2RGB(Self_.fColor2))
- else
- CShadow := Color2RGB( Self_.fColor2 );
- if not Self_.fTransparent then
- Target.FillRect( CR ); // GDIFlush; for test only
- //Target.DeselectHandles;
- Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- SetBkMode( Target.fHandle, Windows.TRANSPARENT );
- if Self_.fCtl3D then
- begin
- I := - Self_.fShadowDeep;
- Istp := 1;
- if Self_.ShadowDeep > 0 then Istp := -1;
- repeat
- J := - Self_.fShadowDeep;
- repeat
- if not ( (I=0) and (J=0) ) then
- begin
- if (I * Istp < 0) and (J * Istp < 0) then
- begin
- doTextOut( I, J, CShadow );
- end;
- end;
- J := J - Istp;
- until J = Self_.fShadowDeep - IStp;
- I := I - Istp;
- until I = Self_.fShadowDeep - IStp;
- end
- else
- doTextout( Self_.fShadowDeep, Self_.fShadowdeep, CShadow );
- doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
- end
- else
- begin
- Target.RequiredState( HandleValid or FontValid or BrushValid or ChangingCanvas );
- SetBkMode( Target.fHandle, Windows.TRANSPARENT );
- doTextout( 0, 0, Color2RGB(Self_.fTextColor) );
- end;
- end;
- if assigned( Self_.fCanvas ) then
- Self_.fCanvas.SetHandle( 0 );
- if MSg.wParam = 0 then
- EndPaint( Self_.fHandle, PS );
- Self_.fPaintDC := OldPaintDC;
- Rslt := 0;
- Result := True;
- Exit;
- end;
- end;
- end;
-
- //[procedure TControl.DoClick]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.DoClick;
- begin
- fControlClick( @Self );
- if Assigned( fOnClick ) then
- fOnClick( @Self );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[function TControl.ParentForm]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ParentForm: PControl;
- begin
- Result := @Self;
- if Result.fIsControl then
- repeat
- Result := Result.fParent;
- until (Result = nil) or not Result.fIsControl;
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- //[procedure TControl.SetProgressColor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetProgressColor(const Value: TColor);
- begin
- {$ifdef win32}
- if Perform( PBM_SETBARCOLOR, 0, Color2RGB(Value) ) <> 0 then
- fTextColor := Value;
- {$endif win32}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetShadowDeep]
- procedure TControl.SetShadowDeep(const Value: Integer);
- begin
- fShadowDeep := Value;
- Invalidate;
- end;
- {$ENDIF WIN_GDI}
-
- //[function TControl.GetFont]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetFont: PGraphicTool;
- begin
- if FFont = nil then
- begin
- FFont := NewFont;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Add2AutoFree( FFont );
- {$ENDIF}
- FFont.fData.Color := fTextColor;
- FFont.OnChange := FontChanged;
- end;
- Result := FFont;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[function TControl.GetBrush]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetBrush: PGraphicTool;
- begin
- if FBrush = nil then
- begin
- FBrush := NewBrush;
- FBrush.fData.Color := fColor;
- FBrush.OnChange := BrushChanged;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Add2AutoFree( FBrush );
- {$ENDIF}
- end;
- Result := FBrush;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- //[procedure TControl.FontChanged]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.FontChanged(Sender: PGraphicTool);
- begin
- fTextColor := Sender.fData.Color;
- ApplyFont2Wnd;
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF WIN_GDI}
- //[procedure TControl.BrushChanged]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.BrushChanged(Sender: PGraphicTool);
- begin
- fColor := Sender.fData.Color;
- if fTmpBrush <> 0 then
- begin
- DeleteObject( fTmpBrush );
- fTmpBrush := 0;
- end;
- if fPaintDC = 0 then
- // only if not in painting already :
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- {$IFDEF GDI}
- //[procedure DoApplyFont2Wnd]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure DoApplyFont2Wnd( _Self: PControl );
- begin
- if _Self.fFont <> nil then
- begin
- if _Self.fHandle <> 0 then
- begin
- _Self.fTextColor := _Self.fFont.fData.Color;
- _Self.Perform( WM_SETFONT, _Self.FFont.Handle, 1 );
- end;
-
- if (_Self.fCanvas <> nil) and (_Self.fCanvas.fFont <> nil) then
- _Self.fCanvas.fFont.Assign(_Self.fFont);
-
- if Assigned( _Self.fAutoSize ) then
- _Self.fAutoSize( _Self );
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure DoApplyFont2Wnd( _Self: PControl );
- var oldfontdesc: PPangoFontDescription;
- rcstyle: PGtkRcStyle;
- gcolor: TGdkColor;
- i: Integer;
- begin
- if Assigned( _Self.fFont ) then
- begin
- gcolor := Color2GdkColor( _Self.fFont.Color );
-
- rcstyle := gtk_widget_get_modifier_style( _Self.fHandle );
- oldfontdesc := rcstyle.font_desc;
- rcstyle.font_desc :=
- pango_font_description_copy( _Self.fFont.GetPangoFontDesc );
- gtk_widget_modify_style( _Self.fHandle, rcstyle );
-
- if oldfontdesc <> nil then
- pango_font_description_free( oldfontdesc );
-
- for i := 0 to 4 do
- gtk_widget_modify_fg( _Self.fCaptionHandle, {GTK_STATE_NORMAL} i, @ gcolor );
- end;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.ApplyFont2Wnd]
- procedure TControl.ApplyFont2Wnd;
- begin
- if Assigned( ApplyFont2Wnd_Proc ) then
- ApplyFont2Wnd_Proc( @ Self );
- end;
-
- {$IFDEF WIN_GDI}
- //[function TControl.ResizeParent]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ResizeParent: PControl;
- begin
- ResizeParentBottom;
- ResizeParentRight;
- // Once again, to fix Windows (or my???) bug with
- // incorrect calculating of GetClientRect after
- // SetWindowLong( GWL_[EX}STYLE,... )
- Result := ResizeParentBottom;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.ResizeParentBottom]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ResizeParentBottom: PControl;
- var NewCH: Integer;
- begin
- Result := @Self;
- if fParent <> nil then
- begin
- NewCH := BoundsRect.Bottom + fParent.fMargin;
- if (fParent.fChangedPosSz and $20) <> 0 then
- if NewCH <> fParent.ClientHeight then Exit;
- fParent.ClientHeight := NewCH;
- fParent.fChangedPosSz := fParent.fChangedPosSz or $20;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.ResizeParentRight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.ResizeParentRight: PControl;
- var NewCW: Integer;
- begin
- Result := @Self;
- if fParent <> nil then
- begin
- NewCW := fBoundsRect.Right + fParent.fMargin;
- if (fParent.fChangedPosSz and $10) <> 0 then
- if NewCW < fParent.ClientWidth then Exit;
- fParent.ClientWidth := NewCW;
- fParent.fChangedPosSz := fParent.fChangedPosSz or $10;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetClientHeight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetClientHeight: Integer;
- begin
- with ClientRect do
- Result := Bottom - Top;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetClientWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetClientWidth: Integer;
- begin
- with ClientRect do
- Result := Right - Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetClientHeight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetClientHeight(const Value: Integer);
- var Delta: Integer;
- begin
- Delta := ClientHeight;
- Delta := Height - Delta;
- Height := Value + Delta;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetClientWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetClientWidth(const Value: Integer);
- var Delta: Integer;
- begin
- Delta := ClientWidth;
- Delta := Width - Delta;
- Width := Value + Delta;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.CenterOnParent]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.CenterOnParent: PControl;
- var PCR: TRect;
- begin
- Result := @Self;
- if (fParent = nil) or not fIsControl then
- PCR := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) )
- else
- PCR := fParent.ClientRect;
- GetWindowHandle;
- Left := (PCR.Right - PCR.Left - Width) div 2;
- Top := (PCR.Bottom - PCR.Top - Height) div 2;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetHasBorder]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetHasBorder: Boolean;
- begin
- UpdateWndStyles;
- Result := LongBool( fStyle and (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME))
- or LongBool( fExStyle and WS_EX_CLIENTEDGE );
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_noVERSION} // YS
- //[procedure TControl.SetHasBorder]
- procedure TControl.SetHasBorder(const Value: Boolean);
- const style_mask = WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION
- or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU;
- exstyle_mask = not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME
- or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
- asm
-
- PUSH EAX
- PUSH EDX
-
- CALL GetHasBorder
- POP ECX
- CMP AL, CL
-
- POP EAX
- JZ @@exit
-
- MOV EDX, [EAX].fStyle
- DEC CL
- MOVZX ECX, [EAX].fIsControl
- JNZ @@1
-
- OR EDX, WS_THICKFRAME
- INC ECX
- LOOP @@set_style
- OR EDX, style_mask
- JMP @@set_style
-
- @@1: AND EDX, not style_mask
- INC ECX
- LOOP @@2
- OR EDX, WS_POPUP
-
- @@2: PUSH EDX
-
- MOV EDX, [EAX].fExStyle
- AND EDX, exstyle_mask
-
- PUSH EAX
- CALL SetExStyle
- POP EAX
-
- POP EDX
- @@set_style:
- TEST [EAX].fTabStop, 1
- JZ @@no_tabstop
- OR DX, WS_TABSTOP
- JMP @@set_style_1
- @@no_tabstop:
- AND DX, not WS_TABSTOP
- @@set_style_1:
- CALL SetStyle
- @@exit:
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetHasBorder(const Value: Boolean);
- var NewStyle: DWORD;
- begin
- if Value = GetHasBorder then Exit;
- if Value then
- begin
- if not fIsControl then
- Style := fStyle or WS_BORDER or WS_CAPTION or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU
- {$ifdef win32}or WS_THICKFRAME or WS_DLGFRAME{$endif}
- else
- {$ifdef win32}
- if fCtl3D then
- ExStyle := fExStyle or WS_EX_CLIENTEDGE
- else
- {$endif win32}
- Style := fStyle or WS_BORDER;
- end
- else
- begin
- NewStyle := fStyle and not (WS_BORDER or WS_THICKFRAME or WS_DLGFRAME or WS_CAPTION
- or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or WS_SYSMENU);
- {$ifdef win32}
- if not fIsControl then NewStyle := NewStyle or WS_POPUP;
- {$endif win32}
- Style := NewStyle;
- {$ifdef win32}
- ExStyle := fExStyle and not (WS_EX_CONTROLPARENT or WS_EX_DLGMODALFRAME
- or WS_EX_WINDOWEDGE or WS_EX_CLIENTEDGE);
- {$endif win32}
- end;
- //+MTsv DN
- if fIsControl then
- if fTabStop then Style := fStyle or WS_TABSTOP
- else Style := fStyle {xor} and not WS_TABSTOP;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetHasCaption]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetHasCaption: Boolean;
- begin
- UpdateWndStyles;
- Result := LongBool( fStyle and (WS_CAPTION xor WS_BORDER));
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetHasCaption]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetHasCaption(const Value: Boolean);
- begin
- if Value = GetHasCaption then Exit;
- if Value then
- begin
- Style := fStyle {$ifdef win32}and not (WS_POPUP or WS_DLGFRAME){$endif} or WS_CAPTION;
- end
- else
- begin
- if fIsControl then
- Style := fStyle and not WS_CAPTION or WS_DLGFRAME
- else
- Style := fStyle and not (WS_CAPTION or WS_SYSMENU xor WS_BORDER){$ifdef win32} or WS_POPUP{$endif};
- {$ifdef win32}
- ExStyle := fExStyle or WS_EX_DLGMODALFRAME;
- {$endif win32}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetCanResize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetCanResize: Boolean;
- begin
- //UpdateWndStyles;
- //Result := LongBool( fStyle and WS_THICKFRAME);
- Result := not fPreventResize;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function WndProcCanResize]
- function WndProcCanResize( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
- var W, H: Integer;
- P: PMinMaxInfo;
- begin
- if not Sender.CanResize then
- if M.message = WM_GETMINMAXINFO then
- begin
- Rslt := Sender.CallDefWndProc( M );
- W := Sender.FFixWidth;
- H := Sender.FFixHeight;
- P := Pointer( M.lParam );
- P.ptMinTrackSize.x := W;
- P.ptMinTrackSize.y := H;
- P.ptMaxTrackSize := P.ptMinTrackSize;
- Result := True; // stop further processing (prevent resizing)
- Exit;
- end
- else
- {$ifdef win32}
- if M.message = WM_NCHITTEST then
- begin
- Rslt := Sender.CallDefWndProc( M );
- if (Rslt >= 10) and (Rslt <= 17) then
- begin
- {$IFDEF CANRESIZE_THICKFRAME}
- Rslt := {-}HTBORDER{+}{++}(*18{HTBORDER}*){--};
- {$ELSE}
- Rslt := HTNOWHERE;
- {$ENDIF}
- Result := True;
- exit;
- end;
- end
- {$endif win32};
- Result := False; // continue message processing
- end;
-
- //[procedure TControl.SetCanResize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCanResize( const Value: Boolean );
- begin
- if Value = CanResize then Exit;
- fPreventResize := not Value;
- {$IFDEF CANRESIZE_THICKFRAME}
- if Value then
- Style := Style or WS_THICKFRAME
- else
- Style := Style and not WS_THICKFRAME;
- {$ENDIF}
- GetWindowHandle;
- FFixWidth := Width;
- FFixHeight := Height;
- AttachProc( WndProcCanResize );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetStayOnTop]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetStayOnTop: Boolean;
- begin
- UpdateWndStyles;
- Result := LongBool( fExStyle and WS_EX_TOPMOST);
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetStayOnTop]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetStayOnTop(const Value: Boolean);
- begin
- if Value = GetStayOnTop then Exit;
- if fHandle <> 0 then
- if Value then
- SetWindowPos( fHandle, HWND_TOPMOST, 0,0,0,0,
- SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
- else
- SetWindowPos( fHandle, HWND_NOTOPMOST, 0,0,0,0,
- SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE )
- else
- if Value then fExStyle := fExStyle or WS_EX_TOPMOST
- else fExStyle := fExStyle and not WS_EX_TOPMOST;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.UpdateWndStyles]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.UpdateWndStyles: PControl;
- begin
- Result := @Self;
- if fHandle = 0 then Exit;
- fStyle := GetWindowLong( fHandle, GWL_STYLE );
- fExStyle := GetWindowLong( fHandle, GWL_EXSTYLE );
- fClsStyle := GetClassLong( fHandle, GCL_STYLE );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetChecked]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetChecked: Boolean;
- begin
- if bboFixed in fBitBtnOptions then
- Result := fChecked
- else
- Result := LongBool( Perform( BM_GETCHECK, 0, 0 ) ) ; //= BST_CHECKED;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Set_Checked]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.Set_Checked(const Value: Boolean);
- begin
- if bboFixed in fBitBtnOptions then
- begin
- fChecked := Value;
- Invalidate;
- end
- else
- Perform( BM_SETCHECK, Integer( Value ), 0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.SetChecked]
- function TControl.SetChecked(const Value: Boolean): PControl;
- begin
- Perform( BM_SETCHECK, Integer( Value ), 0 );
- Result := @Self;
- end;
-
- //[function TControl.SetRadioCheckedOld]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.SetRadioCheckedOld: PControl;
- begin
- Result := @Self;
- if fParent = nil then Exit;
- CheckRadioButton( fParent.GetWindowHandle,
- fParent.fRadio1st,
- fParent.fRadioLast,
- fMenu );
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TControl.SetRadioChecked]
- {$IFDEF ASM_VERSION}
- {$ELSE PAS_VERSION}
- function TControl.SetRadioChecked: PControl;
- var WasTabStop: Boolean;
- begin
- WasTabStop := fTabStop;
- fTabStop := FALSE;
- DoClick;
- fTabStop := WasTabStop;
- Result := @Self;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetCheck3]
- function TControl.GetCheck3: TTriStateCheck;
- begin
- Result := TTriStateCheck(Perform(BM_GETCHECK, 0, 0) and 3);
- end;
-
- //[procedure TControl.SetCheck3]
- procedure TControl.SetCheck3(value: TTriStateCheck);
- var
- wp: WPARAM;
- begin
- wp := Perform(BM_GETCHECK, 0, 0) and not 3;
- wp := wp or WPARAM(ord(value));
- Perform(BM_SETCHECK, wp, 0);
- end;
-
- //*
- //[procedure TControl.Click]
- procedure TControl.Click;
- begin
- if (fCommandActions.aClick <> 0) or
- (fCommandActions.aEnter = BN_SETFOCUS) then
- Perform( WM_COMMAND, (fCommandActions.aClick shl 16) or fMenu,
- GetWindowHandle )
- else
- begin
- Perform( WM_LBUTTONDOWN, MK_LBUTTON, 0 );
- Perform( WM_LBUTTONUP, MK_LBUTTON, 0 );
- end;
- end;
-
- type
- TCharRange = record
- cpMin: Longint;
- cpMax: LongInt;
- end;
-
- //[function TControl.GetSelStart]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetSelStart: Integer;
- //var SR: TCharRange;
- begin
- Result := 0;
- if fCommandActions.aGetSelRange <> 0 then
- //Result := LoWord( Perform( fCommandActions.aGetSelRange, 0, 0 ) )
- Perform( fCommandActions.aGetSelRange, Integer( @ Result ), 0 )
- {else
- if fCommandActions.aExGetSelRange <> 0 then
- begin
- Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );
- Result := SR.cpMin;
- end};
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetSelStart]
- procedure TControl.SetSelStart(const Value: Integer);
- begin
- ItemSelected[ Value ] := True;
- end;
-
- //[function TControl.GetSelLength]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetSelLength: Integer;
- var Start, Finish: Integer;
- begin
- Result := 0;
- if fCommandActions.aGetSelCount <> 0 then
- begin
- if fCommandActions.aGetSelCount = EM_GETSEL then
- begin
- Perform( fCommandActions.aGetSelCount, Integer( @ Start ), Integer( @ Finish ) );
- Result := Finish - Start;
- end
- else
- begin
- Result := Perform( fCommandActions.aGetSelCount {and $7FFF}, 0, 0 );
- end;
- end
- {else
- if fCommandActions.aExGetSelRange <> 0 then
- begin
- Perform( fCommandActions.aExGetSelRange, 0, Integer( @SR ) );
- Result := SR.cpMax - SR.cpMin;
- end};
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetSelLength]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetSelLength(const Value: Integer);
- var SR: TCharRange;
- begin
- SR.cpMin := GetSelStart;
- SR.cpMax := SR.cpMin + Value;
- if Value < 0 then
- SR.cpMax := -1;
- if fCommandActions.aSetSelRange <> 0 then
- Perform( fCommandActions.aSetSelRange, SR.cpMin, SR.cpMax )
- else
- if fCommandActions.aExSetSelRange <> 0 then
- Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
- // Preform( EM_SCROLLCARET, 0, 0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetItems]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetItems(Idx: Integer): KOLString;
- var L, Pos: Integer;
- Buf: PKOLChar;
- begin
- Result := '';
- Pos := Item2Pos( Idx );
- Idx := Pos2Item( Pos );
- if fCommandActions.aGetItemLength <> 0 then
- L := Perform( fCommandActions.aGetItemLength, Pos, 0 )
- else
- Exit;
- if L = 0 then Exit;
- GetMem( Buf, (L + 4) * SizeOf( KOLChar ) );
- PDWORD( Buf )^ := L + 1;
- if fCommandActions.aGetItemText <> 0 then
- Perform( fCommandActions.aGetItemText, Idx, Integer( Buf ) );
- Buf[ L ] := #0;
- Result := Buf;
- FreeMem( Buf );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetItems]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetItems(Idx: Integer; const Value: KOLString);
- var Strt, L : DWORD;
- {$IFNDEF NOT_FIX_CURINDEX}
- TmpCurIdx: Integer; // AK - Andrzey Kubasek
- TmpData: DWORD;
- {$ENDIF NOT_FIX_CURINDEX}
- begin
- if fCommandActions.aSetItemText <> 0 then
- begin
- Strt := Item2Pos( Idx );
- L := Item2Pos( Idx + 1 ) - Strt;
- SelStart := Strt;
- SelLength := L;
- Perform( fCommandActions.aSetItemText, 0, Integer( PKOLChar( Value ) ) );
- end
- else
- if fCommandActions.aDeleteItem <> 0 then
- begin
- {$IFNDEF NOT_FIX_CURINDEX}
- TmpCurIdx := CurIndex; // +AK
- TmpData := ItemData[ Idx ];
- {$ENDIF}
- Delete( Idx );
- Insert( Idx, Value );
- {$IFNDEF NOT_FIX_CURINDEX}
- CurIndex := TmpCurIdx; //+AK
- ItemData[ Idx ] := TmpData;
- {$ENDIF}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetItemsCount]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetItemsCount: Integer;
- begin
- Result := 0;
- {$IFDEF DEBUG}
- try
- {$ENDIF}
- if fCommandActions.aGetCount = 0 then Exit;
- Result := Perform( fCommandActions.aGetCount, 0, 0 );
- {$IFDEF DEBUG}
- except
- asm
- int 3
- end;
- end;
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[procedure TControl.SetItemsCount]
- procedure TControl.SetItemsCount(const Value: Integer);
- begin
- if fCommandActions.aSetCount = 0 then Exit;
- Perform( fCommandActions.aSetCount, Value, 0 );
- end;
-
- //[function TControl.Item2Pos]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Item2Pos(ItemIdx: Integer): DWORD;
- begin
- Result := ItemIdx;
- if fCommandActions.aItem2Pos <> 0 then
- begin
- Result := Perform( fCommandActions.aItem2Pos, ItemIdx, 0 );
- //if Result < 0 then Result := 0;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Pos2Item]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Pos2Item(Pos: Integer): DWORD;
- begin
- Result := Pos;
- if fCommandActions.aPos2Item <> 0 then
- Result := Perform( fCommandActions.aPos2Item, Pos, 0 );
- end;
- {$ENDIF ASM_VERSION}
-
- function TControl.SavePosition: TEditPositions;
- var {$IFNDEF NOT_USE_RICHEDIT}
- p: TPoint;
- {$ENDIF USE_RICHEDIT}
- i: Integer;
- begin
- Result.SelStart := SelStart;
- Result.SelLength := SelLength;
- {$IFNDEF NOT_USE_RICHEDIT}
- if fCannotDoubleBuf { TRUE for rich edit, FALSE for edit } then
- begin
- P.X := 0;
- P.Y := 0;
- i := Perform( EM_CHARFROMPOS, 0, Integer( @ P ) );
- Result.TopLine := Pos2Item( i );
- Result.TopColumn := i - Integer( Item2Pos( Result.TopLine ) );
- {$ifdef win32}
- Perform( EM_GETSCROLLPOS, 0, Integer( @ Result.ScrollPos ) );
- {$else}
- Result.ScrollPos.x:=0;
- Result.ScrollPos.y:=0;
- {$endif win32}
- end
- else
- {$ENDIF USE_RICHEDIT}
- begin
- i := 0;
- i := Perform( EM_CHARFROMPOS, 0, i );
- Result.TopLine := HiWord( i );
- Result.TopColumn := LoWord( i ) - Item2Pos( Result.TopLine );
- Result.ScrollPos.Y := GetScrollPos( Handle, SB_VERT );
- Result.ScrollPos.X := GetScrollPos( Handle, SB_HORZ );
- end;
- Result.RestoreScroll := TRUE;
- end;
-
- procedure TControl.RestorePosition( const P: TEditPositions );
- var Cur: TEditPositions;
- begin
- SelStart := P.SelStart;
- SelLength := P.SelLength;
- if P.RestoreScroll then
- begin
- Perform( EM_SCROLLCARET, 0, 0 );
- Cur := SavePosition;
- {$IFNDEF NOT_USE_RICHEDIT}
- if fCannotDoubleBuf then
- begin // RichEdit
- if P.TopLine <> Cur.TopLine then
- Perform( EM_LINESCROLL, 0, P.TopLine - Cur.TopLine );
- {$ifdef win32}
- Perform( EM_SETSCROLLPOS, 0, Integer( @ P.ScrollPos ) );
- {$endif win32}
- end
- else // Edit
- {$ENDIF USE_RICHEDIT}
- begin
- if (P.TopLine <> Cur.TopLine) or
- (P.TopColumn <> Cur.TopColumn) then
- Perform( EM_LINESCROLL, P.TopColumn - Cur.TopColumn,
- P.TopLine - Cur.TopLine );
- SetScrollPos( Handle, SB_VERT, P.ScrollPos.Y, TRUE );
- SetScrollPos( Handle, SB_HORZ, P.ScrollPos.X, TRUE );
- end;
- end;
- end;
-
- procedure TControl.UpdatePosition( var p: TEditPositions; FromPos,
- CountInsertDelChars, CountInsertDelLines: Integer );
- var d: Integer;
- begin
- if (FromPos <= p.SelStart) and (CountInsertDelChars >= 0) or
- (CountInsertDelChars < 0) and
- ((FromPos + Abs( CountInsertDelChars ) <= p.SelStart)
- ) then
- begin
- p.SelStart := p.SelStart + CountInsertDelChars;
- end
- else
- if FromPos >= p.SelStart + p.SelLength then
- begin
- // nothing to do
- end
- else
- if CountInsertDelChars < 0 then // deleting
- begin
- if FromPos - CountInsertDelChars > p.SelStart + p.SelLength then
- CountInsertDelChars := -( p.SelStart + p.SelLength - FromPos );
- if FromPos - CountInsertDelChars >= p.SelStart then
- begin
- d := FromPos - CountInsertDelChars - p.SelStart;
- p.SelLength := p.SelLength - d;
- //inc( CountInsertDelChars, d );
- end;
- inc( p.SelStart, CountInsertDelChars );
- end
- else // inserting
- begin
- if (FromPos > p.SelStart) and (FromPos < p.SelStart + p.SelLength) then
- inc( p.SelLength, CountInsertDelChars )
- else
- if FromPos <= p.SelStart then
- inc( p.SelStart, CountInsertDelChars );
- end;
- p.TopLine := p.TopLine + CountInsertDelLines;
- end;
-
- //[function WndProcTabChar]
- function WndProcTabChar( Sender: PControl; var M: TMsg; var Rslt: Integer ): Boolean;
- begin
- if M.message = WM_CHAR then
- begin
- if M.wParam = 9 then
- Sender.ReplaceSelection( #9, TRUE );
- end;
- Result := FALSE;
- end;
-
- //[function TControl.EditTabChar]
- function TControl.EditTabChar: PControl;
- begin
- AttachProc( WndProcTabChar );
- Result := @Self;
- end;
-
- //[function TControl.Add]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Add(const S: KOLString): Integer;
- begin
- if fCommandActions.aAddItem <> 0 then
- begin
- Result := Perform( fCommandActions.aAddItem, 0, Integer( PKOLChar( S ) ) );
- if Count = 1 then
- ItemSelected[ 0 ] := True;
- end
- else
- begin
- if assigned( fCommandActions.aAddText ) then
- fCommandActions.aAddText( @Self, S )
- else
- Text := Text + S;
- Result := 0;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.Delete]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.Delete(Idx: Integer);
- begin
- if fCommandActions.aDeleteItem <> 0 then
- Perform( fCommandActions.aDeleteItem, Idx, 0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Insert]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Insert(Idx: Integer; const S: KOLString): Integer;
- begin
- if fCommandActions.aInsertItem <> 0 then
- Result := Perform( fCommandActions.aInsertItem, Idx, Integer( PKOLChar( S ) ) )
- else
- Result := -1;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetItemSelected]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetItemSelected(ItemIdx: Integer): Boolean;
- var SS: Integer;
- begin
- if fCommandActions.aGetSelected <> 0 then
- begin
- SS := Perform( fCommandActions.aGetSelected, ItemIdx, LVIS_SELECTED );
- { Though it is written in docs that for combobox lParam for CB_GETCURSEL
- is not used and _must_ be 0, therefore this code is working for
- combobox too. }
- if fCommandActions.aGetSelected <> CB_GETCURSEL then
- ItemIdx := 1;
- Result := SS = ItemIdx;
- end
- else
- begin
- SS := SelStart;
- Result := (ItemIdx >= SS) and (ItemIdx < SS + SelLength);
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetItemSelected]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetItemSelected(ItemIdx: Integer; const Value: Boolean);
- var SR: TCharRange;
- begin
- if fCommandActions.aSetSelected <> 0 then
- Perform( fCommandActions.aSetSelected, Integer( Value ), ItemIdx )
- else
- if fCommandActions.aSetCurrent <> 0 then
- Perform( fCommandActions.aSetCurrent, ItemIdx, 0 )
- else
- if fCommandActions.aSetSelRange <> 0 then
- Perform( fCommandActions.aSetSelRange, ItemIdx, ItemIdx )
- else
- if fCommandActions.aExSetSelRange <> 0 then
- begin
- SR.cpMin := ItemIdx;
- SR.cpMax := ItemIdx;
- Perform( fCommandActions.aExSetSelRange, 0, Integer( @SR ) );
- end
- else
- begin // for ImageShow: set the index and invalidate the control
- FCurIndex := ItemIdx;
- Invalidate;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetCtl3D]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCtl3D(const Value: Boolean);
- begin
- fCtl3Dchild := Value;
- //if fCtl3D = Value then Exit;
- fCtl3D := Value;
- {$ifdef win32}
- UpdateWndStyles;
- if Value then
- begin
- Style := fStyle and not WS_BORDER;
- ExStyle := fExStyle or WS_EX_CLIENTEDGE;
- end
- else
- begin
- Style := fStyle or WS_BORDER;
- ExStyle := fExStyle and not WS_EX_CLIENTEDGE;
- end;
- {$endif win32}
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Shift]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Shift(dX, dY: Integer): PControl;
- begin
- Left := fBoundsRect.Left + dX;
- Top := fBoundsRect.Top + dY;
- Result := @Self;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure SetKeyEvent]
- procedure SetKeyEvent( Self_: PControl );
- begin
- Self_.fWndProcKeybd := WndProcKeybd;
- end;
-
- //[procedure TControl.SetOnChar]
- procedure TControl.SetOnChar(const Value: TOnChar);
- begin
- fOnChar := Value;
- SetKeyEvent( @Self );
- end;
-
- {$IFDEF SUPPORT_ONDEADCHAR}
- //[procedure TControl.SetOnChar]
- procedure TControl.SetOnDeadChar(const Value: TOnChar);
- begin
- fOnDeadChar := Value;
- SetKeyEvent( @Self );
- end;
- {$ENDIF SUPPORT_ONDEADCHAR}
-
- //[procedure TControl.SetOnKeyDown]
- procedure TControl.SetOnKeyDown(const Value: TOnKey);
- begin
- fOnKeyDown := Value;
- SetKeyEvent( @Self );
- end;
-
- //[procedure TControl.SetOnKeyUp]
- procedure TControl.SetOnKeyUp(const Value: TOnKey);
- begin
- fOnKeyUp := Value;
- SetKeyEvent( @Self );
- end;
-
- //[FUNCTION CollectTabControls]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CollectTabControls( Form: PControl ): PList;
- var R: PList;
- function CollectTab( P: PControl ): Boolean;
- var I, J: Integer;
- C, D: PControl;
- begin
- Result := FALSE;
- for I := 0 to P.fChildren.fCount - 1 do
- begin
- C := P.fChildren.fItems[ I ];
- if C.fTabstop and C.fEnabled and C.ToBeVisible and
- (C.fStyle and WS_TABSTOP <> 0) then
- begin
- D := nil;
- for J := 0 to R.fCount - 1 do
- begin
- D := R.fItems[ J ];
- if D.fTabOrder > C.fTabOrder then
- begin
- Result := TRUE;
- R.Insert( J, C );
- break;
- end
- else
- D := nil;
- end;
- if D = nil then
- begin
- R.Add( C );
- Result := TRUE;
- end;
- end;
- if C.fEnabled then
- begin
- if CollectTab( C ) then
- R.Remove( C );
- end;
- end;
- end;
- {$IFDEF DEBUG_COLLECTTABCONTROLS}
- var SL: PStrList;
- i: Integer;
- C: PControl;
- {$ENDIF}
- begin
- R := NewList;
- CollectTab( Form );
- {$IFDEF DEBUG_COLLECTTABCONTROLS}
- SL := NewStrList;
- for i := 0 to R.Count-1 do
- begin
- C := R.Items[ i ];
- SL.Add( Int2Str( C.fTabOrder ) + ' ' + Int2Str( C.fTag ) + ' ' + C.fCaption );
- end;
- SL.SaveToFile( GetStartDir + 'debug_collecttabcontrols.txt' );
- SL.Free;
- {$ENDIF}
-
- Result := R;
- end;
- {$ENDIF ASM_VERSION}
- //[END CollectTabControls]
-
- //[PROCEDURE Tabulate2Next]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure Tabulate2Next( Form: PControl; Dir: Integer );
- var CL : PList;
- I, J : Integer;
- Ctrl1, Ctrl2, C : PControl;
- begin
- CL := CollectTabControls( Form );
-
- I := 0;
- C := Form.fCurrentControl;
- if C <> nil then
- I := C.fTabOrder;
- Ctrl2 := nil;
- Ctrl1 := nil;
- for J := 0 to CL.fCount - 1 do
- begin
- C := CL.fItems[ J ];
- if C.fTabOrder = I then continue;
- if (Ctrl1 = nil)
- and ( (Dir >= 0) and (C.fTabOrder > I)
- or (Dir < 0) and (C.fTabOrder < I) )
- or (Dir >= 0)
- and (C.fTabOrder > I) and (C.fTabOrder < Ctrl1.fTabOrder)
- or (Dir < 0)
- and (C.fTabOrder < I) and (C.fTabOrder > Ctrl1.fTabOrder)
- then Ctrl1 := C;
- if (Ctrl2 = nil)
- or (Dir >= 0) and (C.fTabOrder < Ctrl2.fTabOrder)
- or (Dir < 0) and (C.fTabOrder > Ctrl2.fTabOrder)
- then Ctrl2 := C;
- end;
- if Ctrl1 = nil then
- Ctrl1 := Ctrl2;
- if Ctrl1 <> nil then
- begin
- if (Ctrl1.fHandle <> 0) {$IFDEF USE_GRAPHCTLS} or not Ctrl1.fWindowed {$ENDIF} then
- begin
- Inc( Ctrl1.fClickDisabled );
- Ctrl1.Focused := TRUE;
- Dec( Ctrl1.fClickDisabled );
- end;
- Form.fCurrentControl := Ctrl1;
- end;
- CL.Free;
- end;
- {$ENDIF ASM_VERSION}
- //[END Tabulate2Next]
-
- //[FUNCTION Tabulate2Control]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Tabulate2Control( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
- var Form: PControl;
- begin
- Result := False;
- case Key of
- VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
- VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
- VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
- VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
- else Exit;
- end;
-
- Result := True;
- if checkOnly then Exit;
-
- Form := Self_.ParentForm;
- case Key of
- VK_TAB:
- if GetKeyState( VK_SHIFT ) < 0 then
- Tabulate2Next( Form, -1 )
- else
- Tabulate2Next( Form, 1 );
- VK_RIGHT, VK_DOWN, VK_NEXT: Tabulate2Next( Form, 1 );
- VK_LEFT, VK_UP, VK_PRIOR: Tabulate2Next( Form, -1 );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END Tabulate2Control]
-
- //[FUNCTION Tabulate2ControlEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Tabulate2ControlEx( Self_: PControl; Key: DWORD; checkOnly: Boolean ): Boolean;
- label search_tabcontrol;
- var Form: PControl;
- CL : PList;
- I : Integer;
- CurCtrl, Ctrl, Found : PControl;
- MinDist, Dist: Integer;
- R, R1 : TRect;
- begin
- Result := False;
- case Key of
- VK_TAB: if not (tkTab in Self_.fLookTabKeys) then exit;
- VK_LEFT, VK_RIGHT: if not (tkLeftRight in Self_.fLookTabKeys) then exit;
- VK_UP, VK_DOWN: if not (tkUpDown in Self_.fLookTabKeys) then exit;
- VK_NEXT, VK_PRIOR: if not (tkPageUpPageDn in Self_.fLookTabKeys) then exit;
- else exit;
- end;
-
- Result := True;
- if checkOnly then Exit;
-
- Form := Self_.ParentForm;
- if Key = VK_TAB then
- if GetKeyState( VK_SHIFT ) < 0 then
- Tabulate2Next( Form, -1 )
- else
- Tabulate2Next( Form, 1 )
- else
- begin
- CL := CollectTabControls( Form );
- I := CL.IndexOf( Form.fCurrentControl );
- Found := nil;
- if I >= 0 then
- begin
- CurCtrl := CL.fItems[ I ];
- GetWindowRect( CurCtrl.Handle, R );
- search_tabcontrol:
- MinDist := MaxInt;
- for I := CL.fCount - 1 downto 0 do
- begin
- Ctrl := CL.fItems[ I ];
- if Ctrl = CurCtrl then continue;
- if not (Ctrl.fEnabled and Ctrl.fTabstop) then continue;
- GetWindowRect( Ctrl.Handle, R1 );
- Dist := MaxInt;
- case Key of
- VK_LEFT:
- begin
- if (R1.Bottom < R.Top)
- or (R1.Top >= R.Bottom)
- or (R1.Left > R.Left) then continue;
- Dist := R.Left - R1.Left;
- end;
- VK_RIGHT:
- begin
- if (R1.Bottom < R.Top)
- or (R1.Top >= R.Bottom)
- or (R1.Left < R.Left) then continue;
- Dist := R1.Left - R.Left;
- end;
- VK_UP, VK_PRIOR:
- begin
- if (R1.Right < R.Left)
- or (R1.Left >= R.Right)
- or (R1.Top > R.Top) then continue;
- Dist := R.Top - R1.Top;
- end;
- VK_DOWN, VK_NEXT:
- begin
- if (R1.Right < R.Left)
- or (R1.Left >= R.Right)
- or (R1.Top < R.Bottom) then continue;
- Dist := R1.Top - R.Top;
- end;
- end;
- if Dist < MinDist then
- begin
- Found := Ctrl;
- MinDist := Dist;
- end;
- end;
- if Found = nil then
- begin
- case Key of
- VK_LEFT:
- begin
- Key := VK_UP; goto search_tabcontrol;
- end;
- VK_RIGHT:
- begin
- Key := VK_DOWN; goto search_tabcontrol;
- end;
- VK_UP, VK_PRIOR:
- Tabulate2Next( Form, -1 );
- VK_DOWN, VK_NEXT:
- Tabulate2Next( Form, 1 );
- end;
- end
- else
- begin
- if Found.fHandle <> 0 then
- begin
- Inc( Found.fClickDisabled );
- SetFocus( Found.fHandle );
- Dec( Found.fClickDisabled );
- end;
- Form.fCurrentControl := Found;
- end;
- end;
- CL.Free;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END Tabulate2ControlEx]
-
- //[function TControl.Tabulate]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Tabulate: PControl;
- var F : PControl;
- begin
- Result := @Self;
- F := ParentForm;
- if F = nil then Exit;
- F.fGotoControl := Tabulate2Control;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TabulateEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TabulateEx: PControl;
- var F : PControl;
- begin
- Result := @Self;
- F := ParentForm;
- if F = nil then Exit;
- F.fGotoControl := Tabulate2ControlEx;
- end;
- {$ENDIF ASM_VERSION}
-
-
- function WndProcMouseTransparent( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- if Msg.message = WM_NCHITTEST then
- begin
- Rslt := HTTRANSPARENT;
- Result := TRUE;
- end;
- end;
-
- function TControl.MouseTransparent: PControl;
- begin
- AttachProc( WndProcMouseTransparent );
- Result := @ Self;
- end;
-
- //*
- //[procedure TControl.GotoControl]
- procedure TControl.GotoControl(Key: DWORD);
- var Form: PControl;
- begin
- Form := ParentForm;
- if Form <> nil then
- if assigned( Form.fGotoControl ) then
- Form.fGotoControl( Form.fCurrentControl, Key, false );
- end;
-
- //[function TControl.GetCurIndex]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetCurIndex: Integer;
- var I, J: Integer;
- begin
- Result := fCurIndex;
- if fCommandActions.aGetCurrent = 0 then
- Exit;
- I := 0;
- if fCommandActions.aGetCurrent = EM_LINEINDEX then
- Dec( I );
- J := 0;
- if fCommandActions.aGetCurrent = LVM_GETNEXTITEM then
- begin
- J := 2 {LVNI_SELECTED};
- Dec( I );
- end;
- Result := Perform( fCommandActions.aGetCurrent, I, J );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetCurIndex]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetCurIndex(const Value: Integer);
- var NMHdr: TNMHdr;
- begin
- if fCommandActions.aSetCurrent <> 0 then
- begin
- Perform( fCommandActions.aSetCurrent, Value, 0 );
- if fCommandActions.aSetCurrent = TCM_SETCURSEL then
- begin
- LongInt(NMHdr.code) := TCN_SELCHANGE;
- NMHdr.hwndFrom := fHandle;
- Perform( WM_NOTIFY, 0, Integer( @NMHdr ) );
- end;
- end
- else
- ItemSelected[ Value ] := True;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- {$IFDEF GDI}
- //[function TControl.GetTextAlign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetTextAlign: TTextAlign;
- begin
- UpdateWndStyles;
- if (fStyle and fCommandActions.aTextAlignRight) = fCommandActions.aTextAlignRight then
- Result := taRight
- else
- if (fStyle and fCommandActions.aTextAlignCenter) = fCommandActions.aTextAlignCenter then
- Result := taCenter
- else
- Result := fTextAlign;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.GetTextAlign: TTextAlign;
- begin
- Result := fTextAlign;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF GDI}
- //[procedure TControl.SetTextAlign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetTextAlign(const Value: TTextAlign);
- var NewStyle: DWORD;
- begin
- fTextAlign := Value;
- NewStyle := 0;
- with fCommandActions do
- case Value of
- taLeft: NewStyle := fStyle and not DWORD(aTextAlignCenter or aTextAlignRight)
- or aTextAlignLeft;
- taRight: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignCenter)
- or aTextAlignRight;
- taCenter: NewStyle := fStyle and not DWORD(aTextAlignLeft or aTextAlignRight)
- or aTextAlignCenter;
- end;
- NewStyle := NewStyle and not DWORD(fCommandActions.aTextAlignMask);
- Style := NewStyle;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetTextAlign(const Value: TTextAlign);
- begin
- if fTextAlign = Value then Exit;
- fTextAlign := Value;
- if Assigned( fSetTextAlign ) then
- fSetTextAlign( @ Self );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF GDI}
- //[function TControl.GetVerticalAlign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetVerticalAlign: TVerticalAlign;
- begin
- UpdateWndStyles;
- if (fStyle and (fCommandActions.aVertAlignCenter shl 8)) = (DWORD(fCommandActions.aVertAlignCenter) shl 8) then
- Result := vaCenter
- else
- if (fStyle and (fCommandActions.aVertAlignBottom shl 8)) = (DWORD(fCommandActions.aVertAlignBottom) shl 8) then
- Result := vaBottom
- else
- Result := fVerticalAlign;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.GetVerticalAlign: TVerticalAlign;
- begin
- Result := fVerticalAlign;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[procedure TControl.SetVerticalAlign]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);
- var NewStyle: DWORD;
- begin
- fVerticalAlign := Value;
- with fCommandActions do
- begin
- NewStyle := fStyle and not DWORD((aVertAlignTop or aVertAlignCenter or aVertAlignBottom) shl 8);
- case Value of
- vaCenter: NewStyle := NewStyle or (aVertAlignCenter shl 8);
- vaTop: NewStyle := NewStyle or (aVertAlignTop shl 8);
- vaBottom: NewStyle := NewStyle or (aVertAlignBottom shl 8);
- end;
- end;
- Style := NewStyle;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure TControl.SetVerticalAlign(const Value: TVerticalAlign);
- begin
- if fVerticalAlign = Value then Exit;
- fVerticalAlign := Value;
- if Assigned( fSetTextAlign ) then
- fSetTextAlign( @ Self );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- {$IFDEF WIN_GDI}
- //[function TControl.Dc2Canvas]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Dc2Canvas( Sender: PCanvas ): HDC;
- begin
- if fPaintDC <> 0 then
- begin
- Result := fPaintDC;
- Sender.SetHandle( Result );
- Sender.fIsPaintDC := True;
- end
- else
- begin
- if Sender.fHandle <> 0 then
- Result := Sender.fHandle
- else
- Result := GetDC( GetWindowHandle );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
-
- //[function TControl.GetCanvas]
- {$IFDEF GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetCanvas: PCanvas;
- begin
- if not assigned( fCanvas ) then
- begin
- fCanvas := NewCanvas( 0 );
- fCanvas.OnGetHandle := Dc2Canvas;
- fCanvas.fOwnerControl := @Self;
- if assigned( fFont ) then
- fCanvas.fFont := fCanvas.fFont.Assign( fFont );
- if assigned( fBrush ) then
- fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );
- end;
- Result := fCanvas;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TControl.ProvideCanvasHandle( Sender: PCanvas ): HDC;
- type PPGdkGC = ^PGdkGC;
- var Array_gc: PPGdkGC;
- begin
- if fInBkPaint then Array_gc := @ fEventboxHandle.style.bg_gc[ 0 ]
- else
- //if fInPaint then
- Array_gc := @ fEventboxHandle.style.fg_gc[ 0 ];
- {CASE fEventboxHandle.state OF
- GTK_STATE_NORMAL : Result := Array_gc[ 0 ];
- GTK_STATE_ACTIVE : Result := Array_gc[ 1 ];
- GTK_STATE_PRELIGHT : Result := Array_gc[ 2 ];
- GTK_STATE_SELECTED : Result := Array_gc[ 3 ];
- GTK_STATE_INSENSITIVE: Result := Array_gc[ 4 ];
- else Result := Array_gc[ 0 ];
- END;}
- CASE fEventboxHandle.state OF
- GTK_STATE_NORMAL,
- GTK_STATE_ACTIVE,
- GTK_STATE_PRELIGHT,
- GTK_STATE_SELECTED,
- GTK_STATE_INSENSITIVE: Result := PPGdkGC( Integer( Array_gc ) + fEventboxHandle.state * sizeof( Pointer ) )^;
- else Result := Array_gc^;
- END;
- end;
-
- function TControl.GetCanvas: PCanvas;
- begin
- if not assigned( fCanvas ) then
- begin
- fCanvas := NewCanvas( nil {fHandle.style.fg_gc[0]} );
- fCanvas.OnGetHandle := ProvideCanvasHandle;
- fCanvas.fOwnerControl := @Self;
- fCanvas.fDrawable := Pointer( fEventboxHandle.window );
- {if assigned( fFont ) then
- fCanvas.fFont := fCanvas.fFont.Assign( fFont );}
- {if assigned( fBrush ) then
- fCanvas.fBrush := fCanvas.fBrush.Assign( fBrush );}
- end;
- //fCanvas.fHandle := fEventboxHandle.style.fg_gc[ 0 ]; // todo: setup desired context
- fCanvas.GetHandle; // ïîëó÷èì çäåñü òîò êîíòåêñò, êîòîðûé ñîîòâåòñòâóåò
- // òåêóùåìó ñîñòîÿíèþ êîíòðîëà (åñëè ýòî êîíòðîë) è òåêóùåé
- // ñòàäèè ðèñîâàíèÿ
- Result := fCanvas;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- {$IFDEF WIN_GDI}
-
- //[function TControl.DblBufTopParent]
- function TControl.DblBufTopParent: PControl;
- var Ctl: PControl;
- begin
- Result := nil;
- Ctl := @ Self;
- while Ctl <> nil do
- begin
- if (Ctl.fDoubleBuffered) or (Ctl.fTransparent) then
- Result := Ctl;
- Ctl := Ctl.fParent;
- end;
- end;
-
- //[procedure TControl.SetDoubleBuffered]
- procedure TControl.SetDoubleBuffered(const Value: Boolean);
- begin
- {$ifdef win32}
- if CannotDoubleBuf then Exit;
- fDoubleBuffered := Value;
- AttachProc(WndProcTransparent);
- {$IFNDEF SMALLEST_CODE}
- Global_AttachProcExtension := @TransparentAttachProcExtension;
- {$ENDIF}
- {$endif win32}
- end;
-
- //[procedure TControl.SetTransparent]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetTransparent(const Value: Boolean);
- begin
- {$ifdef win32}
- fTransparent := Value;
- if fParent = nil then Exit;
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- if not AppTheming then
- fClassicTransparent := Value;
- {$ENDIF}
-
- if Value then begin
- AttachProc(WndProcTransparent);
- fParent.DoubleBuffered := TRUE;
- end;
- {$endif win32}
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.SetBorder]
- function TControl.SetBorder( Value: Integer ): PControl;
- begin
- fMargin := Value;
- Result := @ Self;
- end;
-
- { TTrayIcon }
-
- var FTrayItems: PList;
-
- //[FUNCTION WndProcTray]
- {$IFDEF ASM_noVERSION}
- function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
- asm
- PUSH ECX
- MOV ECX, [EDX].TMsg.message
- CMP CX, CM_TRAYICON
- JNE @@1
-
- MOV ECX, [EDX].TMsg.lParam
- MOV EDX, [EDX].TMsg.wParam
- MOV EAX, [EDX].TTrayIcon.fOnMouse.TMethod.Data
- CMP word ptr [EDX].TTrayIcon.fOnMouse.TMethod.Code+2, 0
- JE @@no_on
-
- CALL [EDX].TTrayIcon.fOnMouse.TMethod.Code
- @@no_on:
- POP ECX
- XOR EAX, EAX
- MOV [ECX], EAX
- INC EAX
- RET
-
- @@1:
- SUB ECX, WM_CLOSE
- JNE @@exit_0
- @@2:
-
- POP ECX
- PUSH EBX
- XCHG EBX, EAX
-
- MOV EAX, [EBX].TControl.fHandle
- CMP EAX, [EDX].TMsg.hwnd
- JNE @@otherwin
-
- MOV EDX, [FTrayItems]
- MOV ECX, [EDX].TList.fCount
- MOV EDX, [EDX].TList.fItems
- @@loop:
- MOV EAX, [EDX + ECX*4 - 4]
- CMP [EAX].TTray.FNoAutoDeactivate, 0
- JNZ @@3
- CMP [EAX].TTrayIcon.fControl, EBX
- JNE @@3
- PUSHAD
- XOR EDX, EDX
- CALL TTrayIcon.SetActive
- POPAD
- @@3: LOOP @@loop
-
- @@otherwin:
- POP EBX
- PUSH ECX
-
- @@exit_0:
- XOR EAX, EAX
- POP ECX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WndProcTray( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
- var Self_: PTrayIcon;
- I : Integer;
- begin
- Result := False;
- case Msg.message of
- CM_TRAYICON:
- begin
- Self_ := Pointer( Msg.wParam );
- if Assigned( Self_.FOnMouse ) then
- Self_.FOnMouse( @Self_, Msg.lParam );
- Rslt := 0;
- Result := True;
- end;
- WM_CLOSE:
- if Msg.hwnd = Control.fHandle then
- begin
- if FTrayItems <> nil then // ?????????????????
- for I := FTrayItems.Count - 1 downto 0 do
- begin
- Self_ := FTrayItems.Items[ I ];
- if not Self_.FNoAutoDeactivate then
- if Self_.FControl = Control then
- Self_.Active := False;
- end;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcTray]
-
- function WndProcTrayIconWnd( Wnd: HWnd; Msg: DWORD; wParam, lParam: Integer ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var PrevProc: function ( Wnd: HWnd; Msg: DWORD;
- wParam, lParam: Integer ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var Tr: PTrayIcon;
- begin
- PrevProc := Pointer( GetProp( Wnd, 'TRAYSAVEPROC' ) );
- if Msg = CM_TRAYICON then
- begin
- Tr := Pointer( wParam );
- if Assigned( Tr.FOnMouse ) then
- Tr.FOnMouse( Tr, lParam );
- Result := 0;
- Exit;
- end
- else
- if Msg = WM_CLOSE then
- begin
- if Assigned( PrevProc ) then
- begin
- SetWindowLong( Wnd, GWL_WNDPROC, Integer( @ PrevProc ) );
- RemoveProp( Wnd, 'TRAYSAVEPROC' );
- PostMessage( Wnd, WM_CLOSE, wParam, lParam );
- Result := 0;
- Exit;
- end;
- end;
- if (Wnd <> 0) and IsWindow( Wnd ) and Assigned( PrevProc ) then
- Result := PrevProc( Wnd, Msg, wParam, lParam )
- else
- Result := DefWindowProc( Wnd, Msg, wParam, lParam );
- end;
-
- //[PROCEDURE TTrayIcon.AttachProc2Wnd]
- procedure TTrayIcon.AttachProc2Wnd;
- begin
- if FWnd = 0 then Exit;
- if GetProp( FWnd, 'TRAYSAVEPROC' ) <> 0 then Exit; // already attached
- SetProp( FWnd, 'TRAYSAVEPROC', GetWindowLong( FWnd, GWL_WNDPROC ) );
- SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ WndProcTrayIconWnd ) );
- end;
- // [END TTrayIcon.AttachProc2Wnd]
-
- // [PROCEDURE TTrayIcon.DetachProc2Wnd]
- procedure TTrayIcon.DetachProc2Wnd;
- var OldProc: function ( Wnd: HWnd; Msg: DWORD;
- wParam, lParam: Integer ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- if FWnd = 0 then Exit;
- OldProc := Pointer( GetProp( FWnd, 'TRAYSAVEPROC' ) );
- if not Assigned( OldProc ) then Exit; // not attached
- SetWindowLong( FWnd, GWL_WNDPROC, Integer( @ OldProc ) );
- RemoveProp( FWnd, 'TRAYSAVEPROC' );
- end;
- // [END TTrayIcon.DetachProc2Wnd]
-
- //[FUNCTION NewTrayIcon]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewTrayIcon( Wnd: PControl; Icon: HIcon ): PTrayIcon;
- begin
- if FTrayItems = nil then
- FTrayItems := NewList;
- {-}
- New( Result, Create );
- {+}{++}(*Result := PTrayIcon.Create;*){--}
- FTrayItems.Add( Result );
- if Wnd <> nil then
- Wnd.AttachProc( WndProcTray );
- Result.FControl := Wnd;
- Result.FIcon := Icon;
- Result.Active := True;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewTrayIcon]
-
- var fRecreateMsg: DWORD;
-
- //[FUNCTION WndProcRecreateTrayIcons]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcRecreateTrayIcons( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- TI: PTrayIcon;
- begin
- if Msg.message = fRecreateMsg then
- begin
- for I := 0 to FTrayItems.fCount - 1 do
- begin
- TI := FTrayItems.Items[ I ];
- if TI.fAutoRecreate then
- if TI.fActive then
- begin
- TI.fActive := False;
- TI.Active := True;
- end;
- end;
- end;
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcRecreateTrayIcons]
-
- const
- TaskbarCreatedMsg: array[ 0..14 ] of KOLChar = ('T','a','s','k','b','a','r',
- 'C','r','e','a','t','e','d',#0);
- //[procedure TTrayIcon.SetAutoRecreate]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TTrayIcon.SetAutoRecreate(const Value: Boolean);
- begin
- fAutoRecreate := Value;
- FControl.ParentForm.AttachProc( WndProcRecreateTrayIcons );
- fRecreateMsg := RegisterWindowMessage( TaskbarCreatedMsg );
- end;
- {$ENDIF ASM_VERSION}
-
- //[destructor TTrayIcon.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TTrayIcon.Destroy;
- begin
- Active := False;
-
- if fIcon <> 0 then
- DestroyIcon( fIcon );
-
- FTrayItems.Remove( @ Self );
- if FTrayItems.Count = 0 then
- Free_And_Nil( FTrayItems );
- FTooltip := '';
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TTrayIcon.SetActive]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
-
- {$ifdef wince}
- const
- NIM_ADD = $00000000;
- NIM_MODIFY = $00000001;
- NIM_DELETE = $00000002;
-
- NIF_MESSAGE = $00000001;
- NIF_ICON = $00000002;
- NIF_TIP = $00000004;
- {$endif wince}
-
- procedure TTrayIcon.SetActive(const Value: Boolean);
- begin
- if FActive = Value then Exit;
- if FIcon = 0 then Exit;
- if (Wnd = 0) and ((FControl = nil) or (FControl.GetWindowHandle = 0)) then Exit;
- FActive := Value;
- if Value then
- SetTrayIcon( NIM_ADD )
- else
- SetTrayIcon( NIM_DELETE );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TTrayIcon.SetIcon]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TTrayIcon.SetIcon(const Value: HIcon);
- var Cmd : DWORD;
- begin
- if FIcon = Value then Exit;
- // Previous icon is not destroying. This is normal for
- // icons, loaded from resources using LoadIcon. For icons,
- // created using CreateIconIndirect, You have to call
- // DestroyIcon manually.
- Cmd := NIM_MODIFY;
- if FIcon = 0 then
- Cmd := NIM_ADD;
- FIcon := Value;
- if FActive then
- SetTrayIcon( Cmd );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TTrayIcon.SetTooltip]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TTrayIcon.SetTooltip(const Value: KOLString);
- begin
- if FTooltip = Value then Exit;
- FTooltip := Value;
- if Active then
- SetTrayIcon( NIM_MODIFY );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TTrayIcon.SetTrayIcon]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TTrayIcon.SetTrayIcon(const Value: DWORD);
- var NID : {$IFDEF UNICODE_CTRLS} TNotifyIconDataW {$ELSE} TNotifyIconData {$ENDIF};
- L : Integer;
- V : DWORD;
- begin
- V := Value;
- if AppletTerminated then
- V := NIM_DELETE;
- if Wnd <> 0 then
- NID.Wnd := Wnd
- else
- NID.Wnd := FControl.fHandle;
-
- NID.cbSize := Sizeof( NID );
- NID.uID := DWORD( @Self );
- NID.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
- if V = NIM_DELETE then
- NID.uFlags := 0;
- NID.uCallbackMessage := CM_TRAYICON;
- NID.hIcon := FIcon;
- L := Length( FToolTip );
- if L > 63 then L := 63;
- Move( FTooltip[1], NID.szTip[0], Min( 63, L ) );
- {$ifdef wince}
- NID.szTip[ L ] := 0;
- {$else wince}
- NID.szTip[ L ] := #0;
- {$endif wince}
- Shell_NotifyIcon( V, @NID );
- end;
- {$ENDIF ASM_VERSION}
-
- { -- JustOne -- }
- var JustOneMutex: THandle;
-
- //[FUNCTION WndProcJustOne]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcJustOne( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
- begin
- Result := False;
- case Msg.message of
- WM_CLOSE{$ifndef wince}, WM_NCDESTROY{$endif}:
- if LongBool( JustOneMutex ) and (Control.Handle = Msg.hwnd) then
- begin
- CloseHandle( JustOneMutex );
- JustOneMutex := 0;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcJustOne]
-
- //[FUNCTION JustOne]
- {$IFDEF ASM_noVERSION}
- function JustOne( Wnd: PControl; const Identifier : String ) : Boolean;
- asm
- PUSH EBX
- PUSH ESI
- XOR ESI, ESI
- PUSH EDI
- XCHG EBX, EAX
-
- CALL EDX2PChar
- PUSH EDX
-
- PUSH 0
- PUSH 1
- PUSH ESI
- MOV EDI, offset[CreateMutex]
- CALL EDI
-
- POP EDX
- TEST EAX, EAX
- JZ @@exit //
- PUSH EAX
- PUSH EAX
-
- PUSH EDX
- PUSH ESI
- PUSH ESI
- CALL EDI
- MOV [JustOneMutex], EAX
- TEST EAX, EAX
- JE @@1 //
-
- PUSH ESI
- PUSH EAX
- CALL WaitForSingleObject
- SUB EAX, WAIT_TIMEOUT
- JE @@1
-
- INC ESI
- @@1:
- XCHG EAX, EBX
- MOV EDX, offset[WndProcJustOne]
- CALL TControl.AttachProc
-
- CALL ReleaseMutex
- CALL CloseHandle
-
- @@exit:
- XCHG EAX, ESI
- POP EDI
- POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function JustOne( Wnd: PControl; const Identifier : KOLString ) : Boolean;
- var CritSecMutex : THandle;
- DW : Longint;
- begin
- Result := False;
- CritSecMutex := CreateMutex( nil, True, nil );
- if CritSecMutex = 0 then Exit;
- {$ifdef UNICODE_CTRLS}
- JustOneMutex := CreateMutexW( nil, False, PKOLChar( Identifier ) );
- {$else}
- JustOneMutex := CreateMutex( nil, False, PChar( Identifier ) );
- {$endif UNICODE_CTRLS}
- if JustOneMutex <> 0 then
- begin
- DW := WaitForSingleObject( JustOneMutex, 0 );
- Result := (DW <> WAIT_TIMEOUT);
- end;
- Wnd.AttachProc( WndProcJustOne );
- CloseHandle( CritSecMutex );
- end;
- {$ENDIF ASM_VERSION}
- //[END JustOne]
-
- var
- JustOneIdentifier: KOLString;
- FoundOtherWnd: HWND;
-
- function JustOneEnumWindowsProc( Wnd : HWnd; Identifier: PKOLChar ) : Boolean; {$ifdef wince}cdecl{$else}{$ifdef wince}cdecl{$else}stdcall{$endif}{$endif};
- begin
- Result:=GetProp(Wnd, Identifier) <> 1;
- if not Result then begin
- SetForegroundWindow(Wnd {$ifdef wince} or 1 {$endif});
- JustOneIdentifier:='';
- FoundOtherWnd:=Wnd;
- end;
- end;
-
- function WndProcJustOneActivate( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
- begin
- Result := False;
- if (Msg.message = WM_DESTROY) and (Control.fHandle = Msg.hwnd) then
- RemoveProp(Msg.hwnd, PKOLChar(JustOneIdentifier));
- end;
-
- function JustOneActivate( Wnd: PControl; const Identifier : KOLString ) : HWND;
- begin
- JustOneIdentifier:=Identifier;
- FoundOtherWnd:=0;
- EnumWindows(@JustOneEnumWindowsProc, DWORD(PKOLChar(Identifier)));
- Result:=FoundOtherWnd;
- if FoundOtherWnd = 0 then begin
- SetProp(Wnd.GetWindowHandle, PKOLChar(Identifier), 1);
- Wnd.AttachProc(WndProcJustOneActivate);
- end;
- end;
-
- {$ifndef wince}
- { JustOneNotify }
-
- var
- OnAnotherInstance: TOnAnotherInstance;
- JustOneMsg: DWORD;
-
- //[FUNCTION WndProcJustOneNotify]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcJustOneNotify( Control: PControl; var Msg: TMsg; var Rslt: Integer ) : Boolean;
- var Buf : array[0..MAX_PATH] of KOLChar;
- begin
- WndProcJustOne( Control, Msg, Rslt );
- Result := False;
- if Msg.message = JustOneMsg then
- begin
- Result := True;
- if assigned( OnAnotherInstance ) then
- begin
- GetWindowText( Msg.lParam, Buf, MAX_PATH );
- OnAnotherInstance( Buf );
- end;
- Rslt := 0;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcJustOneNotify]
-
- // Redefine here incorrectly declared BroadcastSystemMessage API function.
- // It should not refer to BroadcastSystemMessageA, which is not present in
- // earlier versions of Windows95, but to BroadcastSystemMessage, which is
- // present in all Windows95/98/Me and NT/2K/XP.
- //[API BroadcastSystemMessage]
- function BroadcastSystemMessage(Flags: DWORD; Recipients: PDWORD;
- uiMessage: UINT; wParam: WPARAM; lParam: LPARAM): Longint; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external user32 name 'BroadcastSystemMessage';
-
- //[FUNCTION JustOneNotify]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function JustOneNotify( Wnd: PControl; const Identifier : KOLString;
- const aOnAnotherInstance: TOnAnotherInstance ) : Boolean;
- var Recipients : DWord;
- OldCap: String;
- begin
- Result := False;
- JustOneMsg := RegisterWindowMessage( PKOLChar( 'Message.' + Identifier ) );
- if JustOneMsg = 0 then Exit;
-
- Result := JustOne( Wnd, Identifier );
- if not Result then
- begin
- // Send a message to the first instance of applet
- OldCap := Wnd.Caption;
- Wnd.Caption := GetCommandLine;
- if Wnd.GetWindowHandle <> 0 then
- begin
- Recipients := BSM_APPLICATIONS;
- BroadcastSystemMessage( BSF_QUERY or BSF_IGNORECURRENTTASK, @Recipients,
- JustOneMsg, 0, Wnd.fHandle );
- end;
- Wnd.Caption := OldCap;
- end
- else
- begin
- // Store event handler to notify this instance about another
- // instance staring:
- OnAnotherInstance := aOnAnotherInstance;
- Wnd.AttachProc( WndProcJustOneNotify );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END JustOneNotify]
- {$endif wince}
-
- ///////////////////////////////////////// STRING LIST OBJECT /////////////////
-
- {$ENDIF WIN}
- { TStrList }
-
- //[function NewStrList]
- function NewStrList: PStrList;
- begin
- {-}
- New( Result, Create );
- {+}
- {++}(*
- Result := PStrList.Create;
- *){--}
- end;
- //[END NewStrList]
-
- //[destructor TStrList.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TStrList.Destroy;
- begin
- Clear;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Init]
- procedure TStrList.Init;
- begin
- {$IFDEF _D2orD3}
- inherited;
- {$ENDIF}
- fNameDelim := DefaultNameDelimiter;
- end;
-
- //[function TStrList.Add]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.Add(const S: string): integer;
- begin
- Result := fCount;
- Insert( Result, S );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.AddStrings]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.AddStrings(Strings: PStrList);
- begin
- SetText( Strings.Text, True );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Assign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Assign(Strings: PStrList);
- begin
- Clear;
- AddStrings( Strings );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Clear]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Clear;
- var I: Integer;
- begin
- if fCount > 0 then
- for I := fList.Count - 1 downto 0 do
- Delete( I );
- fList.Free;
- fList := nil;
- fCount := 0;
- if fTextBuf <> nil then
- begin
- FreeMem( fTextBuf );
- fTextBuf := nil;
- fTextSiz := 0;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Delete]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Delete(Idx: integer);
- var P: DWORD;
- El:Pointer;
- begin
- P := DWORD( fList.fItems[ Idx ] );
- if (fTextBuf <> nil) and ( P >= DWORD( fTextBuf )) and
- ( P < DWORD( fTextBuf ) + fTextSiz ) then
- else
- begin
- El := FList.Items[ Idx ];
- FreeMem( El );
- end;
- fList.Delete( Idx );
- Dec( fCount );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.DeleteLast]
- procedure TStrList.DeleteLast;
- begin
- Delete( Count-1 );
- end;
-
- //[function TStrList.Get]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.Get(Idx: integer): string;
- begin
- if fList <> nil then
- Result := PChar( fList.Items[ Idx ] )
- else Result := '';
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.GetPChars]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.GetPChars(Idx: Integer): PChar;
- begin
- Result := PChar( fList.fItems[ Idx ] );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.GetTextStr]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.GetTextStr: string;
- var
- I, Len, Size: integer;
- P: PChar;
- begin
- Size := 0;
-
- for I := 0 to fCount - 1 do
- Inc(Size, StrLen( PChar(fList.fItems[I]) ) +
- {$IFDEF LIN} 1 {$ELSE} 2 {$ENDIF});
-
- SetString(Result, nil, Size);
-
- P := Pointer(Result);
- for I := 0 to Count - 1 do
- begin
- Len := StrLen(PChar(fList.fItems[I]));
- if (Len > 0) then
- begin
- System.Move(PChar(fList.fItems[I])^, P^, Len);
- Inc(P, Len);
- end;
- P^ := #13;
- Inc(P);
- {$IFDEF WIN}
- P^ := #10;
- Inc(P);
- {$ENDIF WIN}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.IndexOf]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.IndexOf(const S: string): integer;
- begin
- for Result := 0 to fCount - 1 do
- if (S = PChar( fList.Items[Result] )) then Exit;
- Result := -1;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.IndexOf]
- function TStrList.IndexOf_NoCase(const S: string): integer;
- begin
- for Result := 0 to fCount - 1 do
- if AnsiCompareStrNoCase( S, Items[Result] ) = 0 then Exit;
- Result := -1;
- end;
-
- function TStrList.IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;
- begin
- for Result := 0 to fCount - 1 do
- if (StrLen( PChar( fList.fItems[ Result ] ) ) = DWORD( L )) and
- (StrLComp_NoCase( Str, PChar( fList.fItems[ Result ] ), L ) = 0) then Exit;
- Result := -1;
- end;
-
- //[function TStrList.Find]
- function TStrList.Find(const S: String; var Index: Integer): Boolean;
- var
- L, H, I, C: Integer;
- begin
- Result := FALSE;
- L := 0;
- H := FCount - 1;
- while L <= H do
- begin
- I := (L + H) shr 1;
- C := AnsiCompareStr( PChar( fList.Items[ I ] ), S );
- if C < 0 then L := I + 1 else
- begin
- H := I - 1;
- if C = 0 then
- begin
- Result := TRUE;
- L := I;
- end;
- end;
- end;
- Index := L;
- end;
-
- //[procedure TStrList.Insert]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Insert(Idx: integer; const S: string);
- var Mem: PChar;
- L: Integer;
- begin
- if fList = nil then
- fList := NewList;
- L := Length( S ) + 1;
- GetMem( Mem, L );
- Mem[0] := #0;
- if L > 1 then
- System.Move( S[1], Mem[0], L );
- fList.Insert( Idx, Mem );
- Inc( fCount );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Move]
- procedure TStrList.Move(CurIndex, NewIndex: integer);
- begin
- fList.MoveItem( CurIndex, NewIndex );
- end;
-
- //[procedure TStrList.Put]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Put(Idx: integer; const Value: string);
- begin
- Delete( Idx );
- Insert( Idx, Value );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.SetText]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- //[procedure TStrList.SetText]
- procedure TStrList.SetText(const S: string; Append2List: boolean);
- var
- P, TheLast : PChar;
- L, I : Integer;
-
- procedure AddTextBuf(Src: PChar; Len: DWORD);
- var OldTextBuf, P: PChar;
- I : Integer;
- begin
- if Src <> nil then
- begin
- OldTextBuf := fTextBuf;
- GetMem( fTextBuf, fTextSiz + Len );
- if fTextSiz <> 0 then
- begin
- System.Move( OldTextBuf^, fTextBuf^, fTextSiz );
- for I := 0 to fCount - 1 do
- begin
- P := fList.fItems[ I ];
- if (DWORD( P ) >= DWORD( OldTextBuf )) and
- (DWORD( P ) < DWORD( OldTextBuf ) + fTextSiz) then
- fList.fItems[ I ] := Pointer( DWORD( P ) - DWORD( OldTextBuf ) + DWORD( fTextBuf ) );
- end;
- FreeMem( OldTextBuf );
- end;
- System.Move( Src^, fTextBuf[ fTextSiz ], Len );
- Inc( fTextSiz, Len );
- end;
- end;
-
- begin
- if not Append2List then Clear;
- if S = '' then Exit;
-
- L := fTextSiz;
- AddTextBuf( PChar( S ), Length( S ) + 1 );
-
- P := PChar( DWORD( fTextBuf ) + DWORD( L ) );
- if fList = nil then
- fList := NewList;
-
- I := 0;
- TheLast := P + Length( S );
- while P^ <> #0 do
- begin
- Inc( I );
- {$IFDEF WIN}
- P := StrScanLen( P, #13, TheLast - P );
- if P^ = #10 then
- Inc( P );
- {$ELSE LIN}
- P := StrScanLen( P, #10, TheLast - P );
- {$ENDIF}
- end;
-
- Inc( fCount, I );
- if fList.fCapacity < fCount then
- fList.Capacity := fCount;
-
- P := PChar( DWORD( fTextBuf ) + DWORD( L ) );
- while P^ <> #0 do
- begin
- fList.Add( P );
- {$IFDEF WIN}
- P := StrScanLen( P, #13, TheLast - P );
- if PChar( P - 1 )^ = #13 then
- PChar( P - 1 )^ := #0;
- if P^ = #10 then Inc(P);
- {$ELSE LIN}
- P := StrScanLen( P, #10, TheLast - P );
- {$ENDIF}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.SetUnixText]
- procedure TStrList.SetUnixText(const S: String; Append2List: Boolean);
- var S1: String;
- begin
- S1 := S;
- NormalizeUnixText( S1 );
- SetText( S1, Append2List );
- end;
-
- //[procedure TStrList.SetTextStr]
- procedure TStrList.SetTextStr(const Value: string);
- begin
- SetText( Value, False );
- end;
-
- //[FUNCTION CompareStrListItems]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CompareStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
- var S1, S2 : PChar;
- begin
- S1 := PStrList( Sender ).fList.Items[ e1 ];
- S2 := PStrList( Sender ).fList.Items[ e2 ];
- if PStrList( Sender ).fCaseSensitiveSort then
- Result := StrComp( S1, S2 )
- else
- Result := StrComp( PChar( LowerCase( S1 ) ), PChar( LowerCase( S2 ) ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareStrListItems]
-
- //[FUNCTION CompareAnsiStrListItems]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CompareAnsiStrListItems( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
- var S1, S2 : PKOLChar;
- begin
- S1 := PStrList( Sender ).fList.Items[ e1 ];
- S2 := PStrList( Sender ).fList.Items[ e2 ];
- if PStrList( Sender ).fCaseSensitiveSort then
- Result := _AnsiCompareStr( S1, S2 )
- else
- Result := _AnsiCompareStrNoCase( S1, S2 );
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareAnsiStrListItems]
-
- {$IFNDEF ASM_VERSION}
- //[procedure SwapStrListItems]
- procedure SwapStrListItems( const Sender: Pointer; const e1, e2: DWORD );
- begin
- PStrList( Sender ).Swap( e1, e2 );
- end;
- {$ENDIF}
-
- //[procedure TStrList.Sort]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.Sort(CaseSensitive: Boolean);
- begin
- fCaseSensitiveSort := CaseSensitive;
- SortData( @Self, fCount, @CompareStrListItems, @SwapStrListItems );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.AnsiSort]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.AnsiSort(CaseSensitive: Boolean);
- begin
- fCaseSensitiveSort := CaseSensitive;
- SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListItems );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.Swap]
- procedure TStrList.Swap(Idx1, Idx2: Integer);
- begin
- fList.Swap( Idx1, Idx2 );
- end;
-
- //[function TStrList.Last]
- function TStrList.Last: String;
- begin
- if Count = 0 then
- Result := ''
- else
- Result := Items[ Count - 1 ];
- end;
-
- //-- code by Dod:
- //[function TStrList.IndexOfName]
- function TStrList.IndexOfName(AName: string): Integer;
- var
- i: Integer;
- L: Integer;
- begin
- Result:=-1;
- // Do not start search if empty string
- L := Length( AName );
- if L > 0 then
- begin
- AName := LowerCase( AName ) + fNameDelim;
- Inc( L );
- for i := 0 to fCount - 1 do
- begin
- // For optimization, check only list entry that begin with same letter as searched name
- if StrLComp( PChar( LowerCase( ItemPtrs[ i ] ) ), PChar( AName ), L ) = 0 then
- begin
- Result:=i;
- exit;
- end;
- end;
- end;
- end;
-
- //-- code by Dod:
- //[function TStrList.GetValue]
- function TStrList.GetValue(const AName: string): string;
- var
- i: Integer;
- begin
- I := IndexOfName(AName);
- if I >= 0
- then Result := Copy(Items[i], Length(AName) + 2, Length(Items[i])-Length(AName)-1)
- else Result := '';
- end;
-
- //-- code by Dod:
- //[procedure TStrList.SetValue]
- procedure TStrList.SetValue(const AName, Value: string);
- var
- I: Integer;
- begin
- I := IndexOfName(AName);
- if i=-1
- then Add( AName + fNameDelim + Value )
- else Items[i] := AName + fNameDelim + Value;
- end;
-
- //[function TStrList.GetLineName]
- function TStrList.GetLineName(Idx: Integer): String;
- var s: KOLString;
- begin
- s := Items[ Idx ];
- Result := Parse( s, fNameDelim );
- end;
-
- //[procedure TStrList.SetLineName]
- procedure TStrList.SetLineName(Idx: Integer; const NV: String);
- begin
- Items[ Idx ] := NV + fNameDelim + LineValue[ Idx ];
- end;
-
- //[function TStrList.GetLineValue]
- function TStrList.GetLineValue(Idx: Integer): string;
- var s: KOLString;
- begin
- s := Items[ Idx ];
- Parse( s, fNameDelim );
- Result := s;
- end;
-
- //[procedure TStrList.SetLineValue]
- procedure TStrList.SetLineValue(Idx: Integer; const Value: string);
- begin
- Items[ Idx ] := LineName[ Idx ] + fNameDelim + Value;
- end;
-
- function TStrList.Join( const sep: String ): String;
- var
- I, Len, Size: integer;
- P: PChar;
- begin
- Size := 0;
-
- for I := 0 to Count - 1 do
- Inc(Size, Integer( StrLen( ItemPtrs[I] ) ) + Length(Sep));
-
- SetString(Result, nil, Size);
-
- P := @ Result[ 1 ];
- for I := 0 to Count - 1 do
- begin
- Len := StrLen( ItemPtrs[I] );
- if (Len > 0) then
- begin
- System.Move( ItemPtrs[I]^, P^, Len);
- Inc(P, Len);
- end;
- P := StrPCopy(P, Sep);
- inc( P, Length( Sep ) ); // + by Korneev Ivan
- end;
- end;
-
- {$IFDEF WIN_GDI}
-
- //[function TStrList.AppendToFile]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.AppendToFile(const FileName: KOLstring): Boolean;
- var F: HFile;
- Buf: String;
- L: Integer;
- begin
- F := FileCreate( FileName, ofOpenWrite or ofOpenAlways );
- Result := F <> INVALID_HANDLE_VALUE;
- if Result then
- begin
- FileSeek( F, 0, spEnd );
- Buf := Text;
- L := Length( Buf );
- FileWrite( F, Buf[ 1 ], L );
- FileClose( F );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.LoadFromFile]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.LoadFromFile(const FileName: KOLstring): Boolean;
- var Buf: String;
- F: HFile;
- Sz: Integer;
- begin
- F := FileCreate( FileName, ofOpenRead or ofShareDenyWrite or ofOpenExisting );
- Result := F <> INVALID_HANDLE_VALUE;
- if Result then
- begin
- Sz := GetFileSize( F, nil );
- SetString( Buf, nil, Sz );
- FileRead( F, Buf[1], Sz );
- FileClose( F );
-
- SetText( Buf, False );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.LoadFromStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.LoadFromStream(Stream: PStream; Append2List: boolean);
- var Buf: String;
- Sz: Integer;
- begin
- Sz := Stream.Size - Stream.Position;
- SetString( Buf, nil, Sz );
- Stream.Read( Buf[1], Sz );
- SetText( Buf, Append2List );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.MergeFromFile]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.MergeFromFile(const FileName: KOLstring);
- var TmpStream: PStream;
- begin
- TmpStream := NewReadFileStream( FileName );
- LoadFromStream( TmpStream, True );
- TmpStream.Free;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TStrList.SaveToFile]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TStrList.SaveToFile(const FileName: KOLstring): Boolean;
- var F: HFile;
- Buf: String;
- begin
- F := FileCreate( FileName, ofOpenWrite or ofCreateAlways );
- Result := F <> INVALID_HANDLE_VALUE;
- if Result then
- begin
- Buf := Text;
- FileWrite( F, Buf[ 1 ], Length( Buf ) );
- SetEndOfFile( F ); // necessary! - V.K.
- FileClose( F );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TStrList.SaveToStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TStrList.SaveToStream(Stream: PStream);
- var S: string;
- L: Integer;
- begin
- S := GetTextStr;
- L := Length( S );
- if L <> 0 then
- Stream.Write( S[1], L );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- ////////////////////////////////// EXTENDED STRING LIST OBJECT ////////////////
-
- {-}
- //[procedure WStrCopy]
- {$IFDEF ASM_VERSION}
- procedure WStrCopy( Dest, Src: PWideChar );
- asm
- PUSH EDI
- PUSH ESI
- MOV ESI,EAX
- MOV EDI,EDX
- OR ECX, -1
- XOR EAX, EAX
- REPNE SCASW
- NOT ECX
- MOV EDI,ESI
- MOV ESI,EDX
- REP MOVSW
- POP ESI
- POP EDI
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure WStrCopy( Dest, Src: PWideChar );
- var
- counter : longint;
- Begin
- counter := 0;
- while Src[counter] <> #0 do
- begin
- Dest[counter] := Src[counter];
- Inc(counter);
- end;
- Dest[counter] := #0;
- end;
- {$ENDIF ASM_VERSION}
-
- procedure WStrLCopy( Dest, Src: PWideChar; MaxLen: Integer );
- begin
- while MaxLen > 0 do
- begin
- Dest^ := Src^;
- if Src^ = #0 then break;
- inc( Dest );
- inc( Src );
- dec( MaxLen );
- if MaxLen = 0 then
- Dest^ := Src^;
- end;
- end;
-
- //[function WStrCmp]
- {$IFDEF ASM_VERSION}
- function WStrCmp( W1, W2: PWideChar ): Integer;
- asm
- PUSH ESI
- PUSH EDI
- XCHG ESI, EAX
- MOV EDI, EDX
- XOR EAX, EAX
- @@loop: LODSW
- MOVZX EDX, word ptr [EDI]
- INC EDI
- INC EDI
- CMP EAX, EDX
- JNE @@exit
- TEST EAX, EAX
- JNZ @@loop
- @@exit: SUB EAX, EDX
- POP EDI
- POP ESI
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WStrCmp( W1, W2: PWideChar ): Integer;
- var
- counter: Integer;
- Begin
- counter := 0;
- While W1[counter] = W2[counter] do
- Begin
- if (W2[counter] = #0) or (W1[counter] = #0) then
- break;
- Inc(counter);
- end;
- Result := ord(W1[counter]) - ord(W2[counter]);
- end;
- {$ENDIF ASM_VERSION}
-
- { TStrListEx }
-
- //[function NewStrListEx]
- function NewStrListEx: PStrListEx;
- begin
- {-}
- new( Result, Create );
- {+}
- {++}(*
- Result := PStrListEx.Create;
- *){--}
- end;
- //[END NewStrListEx]
-
- //[destructor TStrListEx.Destroy]
- destructor TStrListEx.Destroy;
- var Obj: PList;
- begin
- Obj := FObjects;
- inherited;
- Obj.Free;
- end;
-
- //[function TStrListEx.GetObjects]
- function TStrListEx.GetObjects(Idx: Integer): DWORD;
- begin
- Result := 0;
- if FObjects.fCount > Idx then
- Result := DWORD( FObjects.Items[ Idx ] );
- end;
-
- //[function TStrListEx.GetObjectCount]
- function TStrListEx.GetObjectCount: Integer;
- begin
- Result := FObjects.Count;
- end;
-
- //[procedure TStrListEx.SetObjects]
- procedure TStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
- begin
- ProvideObjCapacity( Idx + 1 );
- FObjects.Items[ Idx ] := Pointer( Value );
- end;
-
- //[procedure TStrListEx.Init]
- procedure TStrListEx.Init;
- begin
- inherited;
- FObjects := NewList;
- end;
-
- //[procedure SwapStrListExItems]
- procedure SwapStrListExItems( const Sender: Pointer; const e1, e2: DWORD );
- begin
- PStrListEx( Sender ).Swap( e1, e2 );
- end;
-
- //[procedure TStrListEx.AnsiSort]
- procedure TStrListEx.AnsiSort(CaseSensitive: Boolean);
- begin
- fCaseSensitiveSort := CaseSensitive;
- SortData( @Self, fCount, @CompareAnsiStrListItems, @SwapStrListExItems );
- end;
-
- //[procedure TStrListEx.Sort]
- procedure TStrListEx.Sort(CaseSensitive: Boolean);
- begin
- fCaseSensitiveSort := CaseSensitive;
- SortData( @Self, fCount, @CompareStrListItems, @SwapStrListExItems );
- end;
-
- //[procedure TStrListEx.Move]
- procedure TStrListEx.Move(CurIndex, NewIndex: integer);
- begin
- // move string
- fList.MoveItem( CurIndex, NewIndex );
- // move object
- if FObjects.fCount >= Min( CurIndex, NewIndex ) then
- begin
- ProvideObjCapacity( max( CurIndex, NewIndex ) + 1 );
- FObjects.MoveItem( CurIndex, NewIndex );
- end;
- end;
-
- //[procedure TStrListEx.Swap]
- procedure TStrListEx.Swap(Idx1, Idx2: Integer);
- begin
- // swap strings
- fList.Swap( Idx1, Idx2 );
- // swap objects
- if FObjects.fCount >= Min( Idx1, Idx2 ) then
- begin
- ProvideObjCapacity( max( Idx1, Idx2 ) + 1 );
- FObjects.Swap( Idx1, Idx2 );
- end;
- end;
-
- //[procedure TStrListEx.ProvideObjCapacity]
- procedure TStrListEx.ProvideObjCapacity(NewCap: Integer);
- begin
- if FObjects.FCount < NewCap then
- begin
- FObjects.Capacity := NewCap;
- FillChar( FObjects.FItems[ FObjects.FCount ],
- (FObjects.Capacity - FObjects.Count) * sizeof( Pointer ), #0 );
- FObjects.FCount := NewCap;
- end;
- end;
-
- //[procedure TStrListEx.AddStrings]
- procedure TStrListEx.AddStrings(Strings: PStrListEx);
- var I: Integer;
- begin
- I := Count;
- if Strings.FObjects.fCount > 0 then
- ProvideObjCapacity( Count );
- inherited AddStrings( Strings );
- if Strings.FObjects.fCount > 0 then
- begin
- ProvideObjCapacity( I + Strings.FObjects.fCount );
- System.Move( Strings.FObjects.FItems[ 0 ],
- FObjects.FItems[ I ],
- Sizeof( Pointer ) * Strings.FObjects.fCount );
- end;
- end;
-
- //[procedure TStrListEx.Assign]
- procedure TStrListEx.Assign(Strings: PStrListEx);
- begin
- inherited Assign( Strings );
- FObjects.Assign( Strings.FObjects );
- end;
-
- //[procedure TStrListEx.Clear]
- procedure TStrListEx.Clear;
- begin
- inherited;
- FObjects.Clear;
- end;
-
- //[procedure TStrListEx.Delete]
- procedure TStrListEx.Delete(Idx: integer);
- begin
- inherited;
- if FObjects.fCount > Idx then // mdw: '>=' -> '>'
- FObjects.Delete( Idx );
- end;
-
- //[function TStrListEx.LastObj]
- function TStrListEx.LastObj: DWORD;
- begin
- if Count = 0 then
- Result := 0
- else
- Result := Objects[ Count - 1 ];
- end;
-
- //[function TStrListEx.AddObject]
- function TStrListEx.AddObject(const S: String; Obj: DWORD): Integer;
- begin
- Result := Count;
- InsertObject( Count, S, Obj );
- end;
-
- //[procedure TStrListEx.InsertObject]
- procedure TStrListEx.InsertObject(Before: Integer; const S: String; Obj: DWORD);
- begin
- Insert( Before, S );
- ProvideObjCapacity( Before );
- FObjects.Insert( Before, Pointer( Obj ) );
- end;
-
- //[function TStrListEx.IndexOfObj]
- function TStrListEx.IndexOfObj( Obj: Pointer ): Integer;
- begin
- Result := FObjects.IndexOf( Obj );
- end;
-
- //[function WStrLen]
- {$IFDEF ASM_VERSION}
- function WStrLen( W: PWideChar ): Integer;
- asm
- XCHG EDI, EAX
- XCHG EDX, EAX
- OR ECX, -1
- XOR EAX, EAX
- CMP EAX, EDI
- JE @@exit0
- REPNE SCASW
- DEC EAX
- DEC EAX
- SUB EAX, ECX
- @@exit0:
- MOV EDI, EDX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function WStrLen( W: PWideChar ): Integer;
- var i : Integer;
- begin
- i:=0;
- while W[i]<>#0 do inc(i);
- Result:=i;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF _D3orHigher} {$ifdef win32}
- function UTF8_2WideString( const s: AnsiString ): WideString;
- var Buffer: PWideChar;
- L: Integer;
- begin
- L := Length( s ) + 1;
- GetMem( Buffer, L * 2 );
- MultiByteToWideChar( CP_UTF8, 0, PChar( s ), L-1,
- Buffer, L );
- Result := Buffer;
- FreeMem( Buffer );
- end;
- {$endif win32} {$ENDIF _D3orHigher}
-
- {------------------------------------------------------------------------------)
- | |
- | T W S t r L i s t |
- | |
- (------------------------------------------------------------------------------}
-
- {$IFDEF WIN_GDI}
- {$IFNDEF _D2}
-
- //[function NewWStrList]
- function NewWStrList: PWStrList;
- begin
- new( Result, Create );
- end;
-
- { TWStrList }
-
- //[function TWStrList.Add]
- function TWStrList.Add(const W: WideString): Integer;
- begin
- Result := Count;
- Insert( Result, W );
- end;
-
- //[procedure TWStrList.AddWStrings]
- procedure TWStrList.AddWStrings(WL: PWStrList);
- begin
- Text := Text + WL.Text;
- end;
-
- //[function TWStrList.AppendToFile]
- function TWStrList.AppendToFile(const Filename: KOLString): Boolean;
- var Strm: PStream;
- begin
- Strm := NewReadWriteFileStream( Filename );
- Result := Strm.Handle <> INVALID_HANDLE_VALUE;
- if Result then
- begin
- Strm.Position := Strm.Size;
- SaveToStream( Strm );
- end;
- Strm.Free;
- end;
-
- //[procedure TWStrList.Assign]
- procedure TWStrList.Assign(WL: PWStrList);
- begin
- Text := WL.Text;
- end;
-
- //[procedure TWStrList.Clear]
- procedure TWStrList.Clear;
- var I: Integer;
- P: Pointer;
- begin
- for I := 0 to Count-1 do
- begin
- P := fList.Items[ I ];
- if P <> nil then
- if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
- FreeMem( P );
- end;
- if fText <> nil then
- FreeMem( fText );
- fText := nil;
- fTextBufSz := 0;
- fList.Clear;
- end;
-
- //[procedure TWStrList.Delete]
- procedure TWStrList.Delete(Idx: Integer);
- var P: Pointer;
- begin
- P := fList.Items[ Idx ];
- if P <> nil then
- if not( (P >= fText) and (P <= fText + fTextBufSz) ) then
- FreeMem( P );
- fList.Delete( Idx );
- end;
-
- //[destructor TWStrList.Destroy]
- destructor TWStrList.Destroy;
- begin
- Clear;
- fList.Free;
- inherited;
- end;
-
- //[function TWStrList.GetCount]
- function TWStrList.GetCount: Integer;
- begin
- Result := fList.Count;
- end;
-
- //[function TWStrList.GetItems]
- function TWStrList.GetItems(Idx: Integer): WideString;
- begin
- Result := PWideChar( fList.Items[ Idx ] );
- end;
-
- //[function TWStrList.GetPtrs]
- function TWStrList.GetPtrs(Idx: Integer): PWideChar;
- begin
- Result := fList.Items[ Idx ];
- end;
-
- //[function TWStrList.GetText]
- function TWStrList.GetText: WideString;
- const
- EoL: array[ 0..5 ] of Char = ( #13, #0, #10, #0, #0, #0 );
- var L, I: Integer;
- P, Dest: Pointer;
- begin
- L := 0;
- for I := 0 to Count-1 do
- begin
- P := fList.Items[ I ];
- if P <> nil then
- L := L + WStrLen( P ) + 2
- else
- L := L + 2;
- end;
- SetLength( Result, L );
- Dest := PWideChar( Result );
- for I := 0 to Count-1 do
- begin
- P := fList.Items[ I ];
- if P <> nil then
- begin
- WStrCopy( Dest, P );
- Dest := Pointer( cardinal( Dest ) + cardinal(WStrLen( P )) * 2 );
- end;
- WStrCopy( Dest, Pointer( @ EoL[ 0 ] ) );
- Dest := Pointer( cardinal( Dest ) + 4 );
- end;
- end;
-
- //[procedure TWStrList.Init]
- procedure TWStrList.Init;
- begin
- fList := NewList;
- end;
-
- //[procedure TWStrList.Insert]
- procedure TWStrList.Insert(Idx: Integer; const W: WideString);
- var P: Pointer;
- begin
- while Idx > Count do // by Misha Shar. a.k.a. kreit
- fList.Add( nil );
- GetMem( P, (Length( W ) + 1) * Sizeof(WideChar) );
- fList.Insert( Idx, P );
- WStrCopy( P, PWideChar( W ) );
- end;
-
- //[function TWStrList.LoadFromFile]
- function TWStrList.LoadFromFile(const Filename: KOLString): Boolean;
- begin
- Clear;
- Result := MergeFromFile( Filename );
- end;
-
- //[procedure TWStrList.LoadFromStream]
- procedure TWStrList.LoadFromStream(Strm: PStream);
- begin
- Clear;
- MergeFromStream( Strm );
- end;
-
- //[function TWStrList.MergeFromFile]
- function TWStrList.MergeFromFile(const Filename: KOLString): Boolean;
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( Filename );
- Result := Strm.Handle <> INVALID_HANDLE_VALUE;
- if Result then
- MergeFromStream( Strm );
- Strm.Free;
- end;
-
- //[procedure TWStrList.MergeFromStream]
- procedure TWStrList.MergeFromStream(Strm: PStream);
- var Buf: WideString;
- L: Integer;
- begin
- L := Strm.Size - Strm.Position;
- Assert( L mod 1 = 0, 'Wide strings streams must be of even length in bytes.' );
- if L = 0 then Exit;
- SetLength( Buf, L div 2 );
- Strm.Read( Buf[ 1 ], L );
- Text := Text + Buf;
- end;
-
- //[procedure TWStrList.Move]
- procedure TWStrList.Move(IdxOld, IdxNew: Integer);
- begin
- fList.MoveItem( IdxOld, IdxNew );
- end;
-
- //[function TWStrList.SaveToFile]
- function TWStrList.SaveToFile(const Filename: KOLString): Boolean;
- var Strm: PStream;
- begin
- Strm := NewWriteFileStream( Filename );
- Result := Strm.Handle <> INVALID_HANDLE_VALUE;
- if Result then
- SaveToStream( Strm );
- Strm.Free;
- end;
-
- //[procedure TWStrList.SaveToStream]
- procedure TWStrList.SaveToStream(Strm: PStream);
- var Buf, Dest: PWideChar;
- I, L, Sz: Integer;
- P: Pointer;
- begin
- Sz := 0;
- for I := 0 to Count-1 do
- begin
- P := fList.Items[ I ];
- if P <> nil then
- Sz := Sz + WStrLen( P ) * 2 + 4
- else
- Sz := Sz + 4;
- end;
- GetMem( Buf, Sz );
- Dest := Buf;
- for I := 0 to Count-1 do
- begin
- P := fList.Items[ I ];
- if P <> nil then
- begin
- L := WStrLen( P );
- System.Move( P^, Dest^, L * 2 );
- Inc( Dest, L );
- end;
- Dest^ := #13;
- Inc( Dest );
- Dest^ := #10;
- Inc( Dest );
- end;
- Strm.Write( Buf^, Sz );
- FreeMem( Buf );
- end;
-
- //[procedure TWStrList.SetItems]
- procedure TWStrList.SetItems(Idx: Integer; const Value: WideString);
- var P: Pointer;
- begin
- while Idx > Count-1 do
- fList.Add( nil );
- if WStrLen( ItemPtrs[ Idx ] ) > Length( Value ) then // fixed by kreit
- WStrCopy( ItemPtrs[ Idx ], PWideChar( Value ) )
- else
- begin
- P := fList.Items[ Idx ];
- if P <> nil then
- if not ((P >= fText) and (P <= fText + fTextBufSz)) then
- FreeMem( P );
- GetMem( P, (Length( Value ) + 1) * Sizeof(WideChar) );
- fList.Items[ Idx ] := P;
- WStrCopy( P, PWideChar( Value ) );
- end;
- end;
-
- //[procedure TWStrList.SetText]
- procedure TWStrList.SetText(const Value: WideString);
- var L, N: Integer;
- P: PWideChar;
- begin
- Clear;
- if Value = '' then Exit;
- L := (Length( Value ) + 1) * Sizeof( WideChar );
- GetMem( fText, L );
- System.Move( Value[ 1 ], fText^, L );
- fTextBufSz := Length( Value );
- N := 0;
- P := fText;
- while Word( P^ ) <> 0 do
- begin
- if (Word( P^ ) = 13) then
- begin
- Inc( N );
- PWord( P )^ := 0;
- if Word( P[ 1 ] ) = 10 then
- Inc( P );
- end
- else
- if (Word( P^ ) = 10) and ((P = fText) or (Word( (P-1)^ ) <> 0)) then
- begin
- Inc( N );
- PWord( P )^ := 0;
- end;
- Inc( P );
- end;
- fList.Capacity := N;
- P := fText;
- while P < fText + fTextBufSz do
- begin
- fList.Add( P );
- while Word( P^ ) <> 0 do Inc( P );
- Inc( P );
- if Word( P^ ) = 10 then Inc( P );
- end;
- end;
-
- //[function CompareWStrListItems]
- function CompareWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
- var WL: PWStrList;
- begin
- WL := Sender;
- Result := WStrCmp( WL.fList.Items[ Idx1 ], WL.fList.Items[ Idx2 ] );
- end;
-
- //[function CompareWStrListItems_UpperCase]
- function CompareWStrListItems_UpperCase( const Sender: Pointer; const Idx1, Idx2: DWORD ): Integer;
- var WL: PWStrList;
- L1, L2: Integer;
- begin
- WL := Sender;
- L1 := WStrLen( WL.fList.Items[ Idx1 ] );
- L2 := WStrLen( WL.fList.Items[ Idx2 ] );
- if Length( WL.fTmp1 ) < L1 then
- SetLength( WL.fTmp1, L1 + 1 );
- if Length( WL.fTmp2 ) < L2 then
- SetLength( WL.fTmp2, L2 + 1 );
- if L1 > 0 then
- Move( WL.fList.Items[ Idx1 ]^, WL.fTmp1[ 1 ], (L1 + 1) * 2 )
- else
- WL.fTmp1[ 1 ] := #0;
- if L2 > 0 then
- Move( WL.fList.Items[ Idx2 ]^, WL.fTmp2[ 1 ], (L2 + 1) * 2 )
- else
- WL.fTmp2[ 1 ] := #0;
- CharUpperBuffW( PWideChar( WL.fTmp1 ), L1 );
- CharUpperBuffW( PWideChar( WL.fTmp2 ), L2 );
- Result := WStrCmp( PWideChar( WL.fTmp1 ), PWideChar( WL.fTmp2 ) );
- end;
-
- //[procedure SwapWStrListItems]
- procedure SwapWStrListItems( const Sender: Pointer; const Idx1, Idx2: DWORD );
- var WL: PWStrList;
- begin
- WL := Sender;
- WL.Swap( Idx1, Idx2 );
- end;
-
- //[procedure TWStrList.Sort]
- procedure TWStrList.Sort( CaseSensitive: Boolean );
- begin
- if CaseSensitive then
- SortData( @ Self, Count, @CompareWStrListItems, @SwapWStrListItems )
- else
- begin
- SortData( @ Self, Count, @CompareWStrListItems_UpperCase, @SwapWStrListItems );
- fTmp1 := '';
- fTmp2 := '';
- end;
- end;
-
- //[procedure TWStrList.Swap]
- procedure TWStrList.Swap(Idx1, Idx2: Integer);
- begin
- fList.Swap( Idx1, Idx2 );
- end;
-
- function TWStrList.IndexOf( const s: WideString ): Integer;
- var i: Integer;
- p: PWideChar;
- begin
- for i := 0 to Count-1 do
- begin
- p := ItemPtrs[ i ];
- if (p <> nil) and
- (WStrCmp( PWideChar( s ), p ) = 0) then
- begin
- Result := i;
- Exit;
- end;
- end;
- Result := -1;
- end;
-
- //[function NewWStrListEx]
- function NewWStrListEx: PWStrListEx;
- begin
- new( Result, Create );
- end;
-
- { TWStrListEx }
-
- //[function TWStrListEx.AddObject]
- function TWStrListEx.AddObject(const S: WideString; Obj: DWORD): Integer;
- begin
- Result := Count;
- InsertObject( Count, S, Obj );
- end;
-
- //[procedure TWStrListEx.AddWStrings]
- procedure TWStrListEx.AddWStrings(WL: PWStrListEx);
- var I: Integer;
- begin
- I := Count;
- if WL.FObjects.Count > 0 then
- ProvideObjectsCapacity( Count );
- inherited AddWStrings( WL );
- if WL.FObjects.Count > 0 then
- begin
- ProvideObjectsCapacity( I + WL.FObjects.Count );
- System.Move( WL.FObjects.FItems[ 0 ],
- FObjects.FItems[ I ],
- Sizeof( Pointer ) * WL.FObjects.Count );
- end;
- end;
-
- //[procedure TWStrListEx.Assign]
- procedure TWStrListEx.Assign(WL: PWStrListEx);
- begin
- inherited Assign( WL );
- FObjects.Assign( WL.FObjects );
- end;
-
- //[procedure TWStrListEx.Clear]
- procedure TWStrListEx.Clear;
- begin
- inherited Clear;
- FObjects.Clear;
- end;
-
- //[procedure TWStrListEx.Delete]
- procedure TWStrListEx.Delete(Idx: Integer);
- begin
- inherited Delete( Idx );
- if FObjects.FCount >= Idx then
- FObjects.Delete( Idx );
- end;
-
- //[destructor TWStrListEx.Destroy]
- destructor TWStrListEx.Destroy;
- begin
- fObjects.Free;
- inherited;
- end;
-
- //[function TWStrListEx.GetObjects]
- function TWStrListEx.GetObjects(Idx: Integer): DWORD;
- begin
- Result := DWORD( fObjects.Items[ Idx ] );
- end;
-
- //[function TWStrListEx.IndexOfObj]
- function TWStrListEx.IndexOfObj(Obj: Pointer): Integer;
- begin
- Result := FObjects.IndexOf( Obj );
- end;
-
- //[procedure TWStrListEx.Init]
- procedure TWStrListEx.Init;
- begin
- inherited;
- fObjects := NewList;
- end;
-
- //[procedure TWStrListEx.InsertObject]
- procedure TWStrListEx.InsertObject(Before: Integer; const S: WideString;
- Obj: DWORD);
- begin
- Insert( Before, S );
- FObjects.Insert( Before, Pointer( Obj ) );
- end;
-
- //[procedure TWStrListEx.Move]
- procedure TWStrListEx.Move(IdxOld, IdxNew: Integer);
- begin
- fList.MoveItem( IdxOld, IdxNew );
- if FObjects.FCount >= Min( IdxOld, IdxNew ) then
- begin
- ProvideObjectsCapacity( Max( IdxOld, IdxNew ) + 1 );
- FObjects.MoveItem( IdxOld, IdxNew );
- end;
- end;
-
- //[procedure TWStrListEx.ProvideObjectsCapacity]
- procedure TWStrListEx.ProvideObjectsCapacity(NewCap: Integer);
- begin
- if fObjects.Capacity >= NewCap then Exit;
- fObjects.Capacity := NewCap;
- FillChar( FObjects.FItems[ FObjects.Count ],
- (FObjects.Capacity - FObjects.Count) * Sizeof( Pointer ), #0 );
- FObjects.FCount := NewCap;
- end;
-
- //[procedure TWStrListEx.SetObjects]
- procedure TWStrListEx.SetObjects(Idx: Integer; const Value: DWORD);
- begin
- ProvideObjectsCapacity( Idx + 1 );
- fObjects.Items[ Idx ] := Pointer( Value );
- end;
-
- {$ENDIF}
- {$ENDIF WIN_GDI}
- {+}
-
-
- //////////////////////////////////////////////////////////////////////////
- // S O R T I N G
- //////////////////////////////////////////////////////////////////////////
-
- { -- qsort -- }
-
- //[PROCEDURE SortData]
- {$IFDEF ASM_VERSION} // translated to BASM by Kladov Vladimir
- procedure SortData( const Data: Pointer; const uNElem: Dword;
- const CompareFun: TCompareEvent;
- const SwapProc: TSwapEvent );
- asm
- CMP EDX, 2
- JL @@exit
-
- PUSH EAX // [EBP-4] = Data
- PUSH ECX // [EBP-8] = CompareFun
- PUSH EBX // EBX = pivotP
- XOR EBX, EBX
- INC EBX // EBX = 1 to pass to qSortHelp as PivotP
- MOV EAX, EDX // EAX = nElem
- CALL @@qSortHelp
- POP EBX
- POP ECX
- POP ECX
- @@exit:
- POP EBP
- RET 4
-
- @@qSortHelp:
- PUSH EBX // EBX (in) = PivotP
- PUSH ESI // ESI = leftP
- PUSH EDI // EDI = rightP
-
- @@TailRecursion:
- CMP EAX, 2
- JG @@2
- JNE @@exit_qSortHelp
- LEA ECX, [EBX+1]
- MOV EDX, EBX
- CALL @@Compare
- JLE @@exit_qSortHelp
- @@swp_exit:
- CALL @@Swap
- @@exit_qSortHelp:
- POP EDI
- POP ESI
- POP EBX
- RET
-
- // ESI = leftP
- // EDI = rightP
- @@2: LEA EDI, [EAX+EBX-1]
- MOV ESI, EAX
- SHR ESI, 1
- ADD ESI, EBX
- MOV ECX, ESI
- MOV EDX, EDI
- CALL @@CompareLeSwap
- MOV EDX, EBX
- CALL @@Compare
-
- JG @@4
- CALL @@Swap
- JMP @@5
- @@4: MOV ECX, EBX
- MOV EDX, EDI
- CALL @@CompareLeSwap
- @@5:
- CMP EAX, 3
- JNE @@6
- MOV EDX, EBX
- MOV ECX, ESI
- JMP @@swp_exit
- @@6: // classic Horae algorithm
-
- PUSH EAX // EAX = pivotEnd
- LEA EAX, [EBX+1]
- MOV ESI, EAX
- @@repeat:
- MOV EDX, ESI
- MOV ECX, EBX
- CALL @@Compare
- JG @@while2
- @@while1:
- JNE @@7
- MOV EDX, ESI
- MOV ECX, EAX
- CALL @@Swap
- INC EAX
- @@7:
- CMP ESI, EDI
- JGE @@qBreak
- INC ESI
- JMP @@repeat
- @@while2:
- CMP ESI, EDI
- JGE @@until
- MOV EDX, EBX
- MOV ECX, EDI
- CALL @@Compare
- JGE @@8
- DEC EDI
- JMP @@while2
- @@8:
- MOV EDX, ESI
- MOV ECX, EDI
- PUSHFD
- CALL @@Swap
- POPFD
- JE @@until
- INC ESI
- DEC EDI
- @@until:
- CMP ESI, EDI
- JL @@repeat
- @@qBreak:
- MOV EDX, ESI
- MOV ECX, EBX
- CALL @@Compare
- JG @@9
- INC ESI
- @@9:
- PUSH EBX // EBX = PivotTemp
- PUSH ESI // ESI = leftTemp
- DEC ESI
- @@while3:
- CMP EBX, EAX
- JGE @@while3_break
- CMP ESI, EAX
- JL @@while3_break
- MOV EDX, EBX
- MOV ECX, ESI
- CALL @@Swap
- INC EBX
- DEC ESI
- JMP @@while3
- @@while3_break:
- POP ESI
- POP EBX
-
- MOV EDX, EAX
- POP EAX // EAX = nElem
- PUSH EDI // EDI = lNum
- MOV EDI, ESI
- SUB EDI, EDX
- ADD EAX, EBX
- SUB EAX, ESI
-
- PUSH EBX
- PUSH EAX
- CMP EAX, EDI
- JGE @@10
-
- MOV EBX, ESI
- CALL @@qSortHelp
- POP EAX
- MOV EAX, EDI
- POP EBX
- JMP @@11
-
- @@10: MOV EAX, EDI
- CALL @@qSortHelp
- POP EAX
- POP EBX
- MOV EBX, ESI
- @@11:
- POP EDI
- JMP @@TailRecursion
-
- @@Compare:
- PUSH EAX
- PUSH EDX
- PUSH ECX
- MOV EAX, [EBP-4]
- DEC EDX
- DEC ECX
- CALL dword ptr [EBP-8]
- POP ECX
- POP EDX
- TEST EAX, EAX
- POP EAX
- RET
-
- @@CompareLeSwap:
- CALL @@Compare
- JG @@ret
-
- @@Swap: PUSH EAX
- PUSH EDX
- PUSH ECX
- MOV EAX, [EBP-4]
- DEC EDX
- DEC ECX
- CALL dword ptr [SwapProc]
- POP ECX
- POP EDX
- TEST EAX, EAX
- POP EAX
- @@ret:
- RET
-
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure SortData( const Data: Pointer; const uNElem: Dword;
- const CompareFun: TCompareEvent;
- const SwapProc: TSwapEvent );
- { uNElem - number of elements to sort }
-
- function Compare( const e1, e2 : DWord ) : Integer;
- begin
- Result := CompareFun( Data, e1 - 1, e2 - 1 );
- end;
-
- procedure Swap( const e1, e2 : DWord );
- begin
- SwapProc( Data, e1 - 1, e2 - 1 );
- end;
-
- procedure qSortHelp(pivotP: Dword; nElem: Dword);
- label
- TailRecursion,
- qBreak;
- var
- leftP, rightP, pivotEnd, pivotTemp, leftTemp: Dword;
- lNum: Dword;
- retval: integer;
- begin
- TailRecursion:
- if (nElem <= 2) then
- begin
- if (nElem = 2) then
- begin
- rightP := pivotP +1;
- retval := Compare(pivotP,rightP);
- if (retval > 0) then Swap(pivotP,rightP);
- end;
- exit;
- end;
- rightP := (nElem -1) + pivotP;
- leftP := (nElem shr 1) + pivotP;
- { sort pivot, left, and right elements for "median of 3" }
- retval := Compare(leftP,rightP);
- if (retval > 0) then Swap(leftP, rightP);
- retval := Compare(leftP,pivotP);
-
- if (retval > 0) then
- Swap(leftP, pivotP)
- else
- begin
- retval := Compare(pivotP,rightP);
- if retval > 0 then Swap(pivotP, rightP);
- end;
- if (nElem = 3) then
- begin
- Swap(pivotP, leftP);
- exit;
- end;
- { now for the classic Horae algorithm }
- pivotEnd := pivotP + 1;
- leftP := pivotEnd;
- repeat
-
- retval := Compare(leftP, pivotP);
- while (retval <= 0) do
- begin
-
- if (retval = 0) then
- begin
- Swap(leftP, pivotEnd);
- Inc(pivotEnd);
- end;
- if (leftP < rightP) then
- Inc(leftP)
- else
- goto qBreak;
- retval := Compare(leftP, pivotP);
- end; {while}
- while (leftP < rightP) do
- begin
- retval := Compare(pivotP, rightP);
- if (retval < 0) then
- Dec(rightP)
-
- else
- begin
- Swap(leftP, rightP);
- if (retval <> 0) then
- begin
- Inc(leftP);
- Dec(rightP);
- end;
- break;
- end;
- end; {while}
-
- until (leftP >= rightP);
- qBreak:
- retval := Compare(leftP,pivotP);
- if (retval <= 0) then Inc(leftP);
-
- leftTemp := leftP -1;
- pivotTemp := pivotP;
- while ((pivotTemp < pivotEnd) and (leftTemp >= pivotEnd)) do
- begin
- Swap(pivotTemp, leftTemp);
- Inc(pivotTemp);
- Dec(leftTemp);
- end; {while}
- lNum := (leftP - pivotEnd);
- nElem := ((nElem + pivotP) -leftP);
-
- if (nElem < lNum) then
- begin
- qSortHelp(leftP, nElem);
- nElem := lNum;
- end
- else
- begin
- qSortHelp(pivotP, lNum);
- pivotP := leftP;
- end;
- goto TailRecursion;
- end; {qSortHelp }
-
- begin
- if (uNElem < 2) then exit; { nothing to sort }
- qSortHelp(1, uNElem);
- end;
- {$ENDIF ASM_VERSION}
- //[END SortData]
-
- //[FUNCTION CompareIntegers]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CompareIntegers( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
- var I1, I2 : Integer;
- begin
- I1 := PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
- I2 := PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
- Result := 0;
- if I1 < I2 then Result := -1
- else
- if I1 > I2 then Result := 1;
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareIntegers]
-
- //[FUNCTION CompareDwords]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CompareDwords( const Sender : Pointer; const e1, e2 : DWORD ) : Integer;
- var I1, I2 : DWord;
- begin
- I1 := PDWORD( DWORD( Sender ) + e1 * Sizeof( Integer ) )^;
- I2 := PDWORD( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
- Result := 0;
- if I1 < I2 then Result := -1
- else
- if I1 > I2 then Result := 1;
- end;
- {$ENDIF ASM_VERSION}
- //[END CompareDwords]
-
- //[PROCEDURE SwapIntegers]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure SwapIntegers( const Sender : Pointer; const e1, e2 : DWORD );
- var Tmp : Integer;
- begin
- Tmp := PInteger( DWORD( Sender ) + e1 * SizeOf( Integer ) )^;
- PInteger( DWORD( Sender ) + e1 * Sizeof( Integer ) )^ :=
- PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^;
- PInteger( DWORD( Sender ) + e2 * Sizeof( Integer ) )^ := Tmp;
- end;
- {$ENDIF ASM_VERSION}
- //[END SwapIntegers]
-
- //[procedure SortIntegerArray]
- procedure SortIntegerArray( var A : array of Integer );
- begin
- SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareIntegers, @SwapIntegers );
- end;
-
- procedure SwapListItems( const L: Pointer; const e1, e2: DWORD );
- begin
- PList( L ).Swap( e1, e2 );
- end;
-
- //[procedure SortDwordArray]
- procedure SortDwordArray( var A : array of DWORD );
- begin
- SortData( @A[ 0 ], High( A ) - Low( A ) + 1, @CompareDwords, @SwapIntegers );
- end;
- {$IFDEF WIN_GDI}
-
- { -- status bar implementation -- }
-
- //[FUNCTION _NewStatusbar]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function _NewStatusbar( AParent: PControl ): PControl;
- var Style: DWORD;
- begin
- Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or 3 or WS_VISIBLE;
- {if AParent.CanResize then
- Style := Style or SBARS_SIZEGRIP;}
- if AParent.fSizeGrip then
- Style := (Style or SBARS_SIZEGRIP) and not 3;
- Result := _NewCommonControl( AParent, STATUSCLASSNAME,
- Style, FALSE, nil );
-
- with Result.fBoundsRect do
- begin
- Left := 0;
- Right := 0;
- Top := 0;
- Bottom := 0;
- end;
- Result.fAlign := caBottom;
- Result.fNotUseAlign := True;
- {$IFDEF TEST_VERSION}
- Result.fTag := DWORD( PChar( 'Status bar' ) );
- {$ENDIF}
- InitCommonControlSizeNotify( Result );
- {$ifdef wince}
- Result.Perform(CCM_SETVERSION, COMCTL32_VERSION, 0);
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
- //[END _NewStatusbar]
-
- //[procedure TControl.SetStatusText]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetStatusText(Index: Integer; Value: PKOLChar);
- var ch: Integer;
- R : TRect;
- N, I, L, W : Integer;
- WidthsBuf: array[ 0..254 ] of Integer;
- begin
- if fStatusCtl = nil then
- begin
- ch := GetClientHeight;
- fStatusCtl := _NewStatusBar( @Self );
- fStatusWnd := fStatusCtl.GetWindowHandle;
- fStatusCtl.Perform( SB_SIMPLE, Integer( LongBool( Index = 255 ) ), 0 );
- GetWindowRect( fStatusWnd, R );
- fClientBottom := R.Bottom - R.Top;
- SetClientHeight( ch );
- SendMessage( fStatusWnd, WM_SIZE, 0, 0 );
- end;
- if Index < 255 then
- begin
- N := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );
- if N <= Index then
- begin
- W := Width;
- L := W div (Index + 1);
- W := L;
- for I := 0 to Index - 1 do
- begin
- WidthsBuf[ I ] := W;
- Inc( W, L );
- end;
- WidthsBuf[ Index ] := -1;
- SendMessage( fStatusWnd, SB_SETPARTS, Index + 1, Integer( @WidthsBuf[ 0 ] ) );
- end;
- SendMessage( fStatusWnd, SB_SIMPLE, 0, 0 );
- end;
- SendMessage( fStatusWnd,
- {$IFDEF UNICODE_CTRLS} SB_SETTEXTW {$ELSE} SB_SETTEXT {$ENDIF}, Index, Integer( Value ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetStatusText]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetStatusText( Index: Integer ): PKOLChar;
- var L, I: Integer;
- Msg: DWORD;
- begin
- Result := nil;
- if fStatusWnd = 0 then Exit;
- if fStatusTxt <> nil then
- FreeMem( fStatusTxt );
- fStatusTxt := nil;
- Msg := SB_GETTEXTLENGTH;
- I := Index;
- if Index = 255 then
- begin
- Msg := WM_GETTEXTLENGTH;
- I := 0;
- end;
- L := SendMessage( fStatusWnd, Msg, I, 0 ) and $FFFF;
- if L > 0 then
- begin
- GetMem( fStatusTxt, (L + 1)*Sizeof(KOLChar) );
- fStatusTxt[ L ] := #0;
- Msg := {$IFDEF UNICODE_CTRLS} SB_GETTEXTW {$ELSE} SB_GETTEXT {$ENDIF};
- if Index = 255 then
- Msg := WM_GETTEXT;
- SendMessage( fStatusWnd, Msg, I, Integer( fStatusTxt ) );
- end;
- Result := fStatusTxt;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.RemoveStatus]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.RemoveStatus;
- var ch: Integer;
- begin
- if fStatusCtl = nil then Exit;
- ch := ClientHeight;
- fStatusWnd := 0;
- fStatusCtl.Free;
- fStatusCtl := nil;
- fClientBottom := 0;
- ClientHeight := ch;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.StatusPanelCount]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.StatusPanelCount: Integer;
- begin
- Result := 0;
- if fStatusWnd = 0 then Exit;
- Result := SendMessage( fStatusWnd, SB_GETPARTS, 0, 0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.GetStatusPanelX]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetStatusPanelX(Idx: Integer): Integer;
- var Buf: array[0..254] of Integer;
- N : Integer;
- begin
- Result := 0;
- if fStatusWnd = 0 then Exit;
- N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
- if N <= Idx then Exit;
- Result := Buf[ Idx ];
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetStatusPanelX]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetStatusPanelX(Idx: Integer; const Value: Integer);
- var Buf: array[0..254] of Integer;
- N : Integer;
- begin
- if fStatusWnd = 0 then Exit;
- N := SendMessage( fStatusWnd, SB_GETPARTS, 255, Integer( @Buf[ 0 ] ) );
- if N <= Idx then Exit;
- Buf[ Idx ] := Value;
- SendMessage( fStatusWnd, SB_SETPARTS, N, Integer( @Buf[ 0 ] ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.SetColor1]
- procedure TControl.SetColor1(const Value: TColor);
- begin
- fColor1 := Value;
- Invalidate;
- end;
-
- //[procedure TControl.SetColor2]
- procedure TControl.SetColor2(const Value: TColor);
- begin
- fColor2 := Value;
- Invalidate;
- end;
-
- //[procedure TControl.SetGradientLayout]
- procedure TControl.SetGradientLayout(const Value: TGradientLayout);
- begin
- FGradientLayout := Value;
- Invalidate;
- end;
-
- //[procedure TControl.SetGradientStyle]
- procedure TControl.SetGradientStyle(const Value: TGradientStyle);
- begin
- FGradientStyle := Value;
- Invalidate;
- end;
-
- { -- Image List -- }
-
- //*
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewImageList]
- function NewImageList( AOwner: PControl ): PImageList;
- begin
- new( Result, CreateImageList( AOwner ) );
- end;
- //[END NewImageList]
- {$ELSE not_USE_CONSTRUCTORS}
- //[function NewImageList]
- function NewImageList( AOwner: PControl ): PImageList;
- begin
- {*************} DoInitCommonControls( ICC_WIN95_CLASSES );
- {-}
- New( Result, Create );
- {+}
- {++}(*Result := TImageList.Create;*){--}
- Result.FAllocBy := 1;
- Result.FMasked := True;
- Result.fBkColor := clNone;
- //ImageList_SetBkColor( Result.FHandle, CLR_NONE );
- Result.FImgWidth := 32;
- Result.FImgHeight := 32;
- Result.FColors := ilcDefault;
-
- if AOwner = nil then exit;
- Result.fNext := PImageList( AOwner.fImageList );
- if AOwner.fImageList <> nil then
- PImageList( AOwner.fImageList ).fPrev := Result;
- Result.FControl := AOwner;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- AOwner.Add2AutoFree( Result );
- {$ENDIF}
- AOwner.fImageList := Result;
- end;
- {$ENDIF}
-
- {$ifdef win32}
- //[API ImageList_XXX]
- function ImageList_Create; {$ifdef wince}cdecl{$else}stdcall{$endif}; external cctrl name 'ImageList_Create';
- function ImageList_Destroy; external cctrl name 'ImageList_Destroy';
- function ImageList_GetImageCount; external cctrl name 'ImageList_GetImageCount';
- function ImageList_SetImageCount; external cctrl name 'ImageList_SetImageCount';
- function ImageList_Add; external cctrl name 'ImageList_Add';
- function ImageList_ReplaceIcon; external cctrl name 'ImageList_ReplaceIcon';
- function ImageList_SetBkColor; external cctrl name 'ImageList_SetBkColor';
- function ImageList_GetBkColor; external cctrl name 'ImageList_GetBkColor';
- function ImageList_SetOverlayImage; external cctrl name 'ImageList_SetOverlayImage';
- function ImageList_Draw; external cctrl name 'ImageList_Draw';
- function ImageList_Replace; external cctrl name 'ImageList_Replace';
- function ImageList_AddMasked; external cctrl name 'ImageList_AddMasked';
- function ImageList_DrawEx; external cctrl name 'ImageList_DrawEx';
- function ImageList_Remove; external cctrl name 'ImageList_Remove';
- function ImageList_GetIcon; external cctrl name 'ImageList_GetIcon';
- {$IFDEF UNICODE_CTRLS}
- function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageW';
- {$ELSE}
- function ImageList_LoadImage; external cctrl name 'ImageList_LoadImageA';
- {$ENDIF}
- function ImageList_BeginDrag; external cctrl name 'ImageList_BeginDrag';
- function ImageList_EndDrag; external cctrl name 'ImageList_EndDrag';
- function ImageList_DragEnter; external cctrl name 'ImageList_DragEnter';
- function ImageList_DragLeave; external cctrl name 'ImageList_DragLeave';
- function ImageList_DragMove; external cctrl name 'ImageList_DragMove';
- function ImageList_SetDragCursorImage; external cctrl name 'ImageList_SetDragCursorImage';
- function ImageList_DragShowNolock; external cctrl name 'ImageList_DragShowNolock';
- function ImageList_GetDragImage; external cctrl name 'ImageList_GetDragImage';
- function ImageList_GetIconSize; external cctrl name 'ImageList_GetIconSize';
- function ImageList_SetIconSize; external cctrl name 'ImageList_SetIconSize';
- function ImageList_GetImageInfo; external cctrl name 'ImageList_GetImageInfo';
- function ImageList_Merge; external cctrl name 'ImageList_Merge';
-
- //[function ImageList_AddIcon]
- function ImageList_AddIcon(ImageList: HImageList; Icon: HIcon): Integer;
- begin
- Result := ImageList_ReplaceIcon(ImageList, -1, Icon);
- end;
-
- //[function Index2OverlayMask]
- function Index2OverlayMask(Index: Integer): Integer;
- begin
- Result := Index shl 8;
- end;
-
- { macros }
- //[procedure ImageList_RemoveAll]
- procedure ImageList_RemoveAll(ImageList: HImageList); {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- ImageList_Remove(ImageList, -1);
- end;
-
- //[function ImageList_ExtractIcon]
- function ImageList_ExtractIcon(Instance: THandle; ImageList: HImageList;
- Image: Integer): HIcon; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result := ImageList_GetIcon(ImageList, Image, 0);
- end;
-
- //[function ImageList_LoadBitmap]
- function ImageList_LoadBitmap(Instance: THandle; Bmp: PKOLChar;
- CX, Grow: Integer; Mask: TColorRef): HImageList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result := ImageList_LoadImage(Instance, Bmp, CX, Grow, Mask, IMAGE_BITMAP, 0);
- end;
- {$endif win32}
-
- //[procedure FreeBmp]
- procedure FreeBmp( Bmp: HBitmap );
- begin
- DeleteObject( Bmp );
- end;
-
- //[function LoadBmp]
- function LoadBmp( Instance: Integer; Rsrc: PKOLChar; MasterObj: PObj ): HBitmap;
- begin
- Result := LoadBitmap( Instance, Rsrc );
- MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
- end;
-
- { TImageList }
-
- //*
- //[function TImageList.Add]
- function TImageList.Add(Bmp, Msk: HBitmap): Integer;
- begin
- Result := -1;
- if not HandleNeeded then Exit;
- Result := ImageList_Add( FHandle, Bmp, Msk );
- end;
-
- //*
- //[function TImageList.AddIcon]
- function TImageList.AddIcon(Ico: HIcon): Integer;
- {var Bmp : HBitmap;
- DC : HDC;}
- begin
- Result := -1;
- if ImgWidth = 0 then
- ImgWidth := 32;
- if ImgHeight = 0 then
- ImgHeight := 32;
- if not HandleNeeded then Exit;
- Result := ImageList_AddIcon( fHandle, Ico );
- end;
-
- //*
- //[function TImageList.AddMasked]
- function TImageList.AddMasked(Bmp: HBitmap; Color: TColor): Integer;
- begin
- Result := -1;
- if not HandleNeeded then Exit;
- Result := ImageList_AddMasked( FHandle, Bmp, Color2RGB( Color ) );
- end;
-
- //+
- //[procedure TImageList.Clear]
- procedure TImageList.Clear;
- begin
- Handle := 0;
- end;
-
- //*
- //[procedure TImageList.Delete]
- procedure TImageList.Delete(Idx: Integer);
- begin
- if FHandle = 0 then Exit;
- ImageList_Remove( FHandle, Idx );
- end;
-
- //[destructor TImageList.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TImageList.Destroy;
- begin
- Clear;
- if fNext <> nil then
- fNext.fPrev := fPrev;
- if fPrev <> nil then
- fPrev.fNext := fNext;
- if fControl <> nil then
- begin
- if PControl( fControl ).fImageList = @Self then
- PControl( fControl ).fImageList := fNext;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- PControl(fControl).RemoveFromAutoFree( @ Self );
- {$ENDIF}
- end;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[procedure TImageList.Draw]
- procedure TImageList.Draw(Idx: Integer; DC: HDC; X, Y: Integer);
- begin
- if FHandle = 0 then Exit;
- ImageList_Draw( FHandle, Idx, DC, X, Y, GetDrawStyle );
- end;
-
- //[function TImageList.ExtractIcon]
- function TImageList.ExtractIcon(Idx: Integer): HIcon;
- begin
- Result := ImageList_ExtractIcon( 0, FHandle, Idx );
- end;
-
- //[function TImageList.ExtractIconEx]
- function TImageList.ExtractIconEx(Idx: Integer): HIcon;
- begin
- Result := ImageList_GetIcon( FHandle, Idx, GetDrawStyle );
- end;
-
- //*
- //[function TImageList.GetBitmap]
- function TImageList.GetBitmap: HBitmap;
- var II : TImageInfo;
- begin
- Result := 0;
- if FHandle = 0 then Exit;
- if ImageList_GetImageInfo( FHandle, 0, II ) then
- Result := II.hbmImage;
- end;
-
- //*
- //[function TImageList.GetBkColor]
- function TImageList.GetBkColor: TColor;
- begin
- Result := fBkColor;
- if FHandle = 0 then Exit;
- Result := ImageList_GetBkColor( FHandle );
- end;
-
- //*
- //[function TImageList.GetCount]
- function TImageList.GetCount: Integer;
- begin
- Result := 0;
- if FHandle <> 0 then
- Result := ImageList_GetImageCount( FHandle );
- end;
-
- //*
- //[function TImageList.GetDrawStyle]
- function TImageList.GetDrawStyle: DWord;
- begin
- Result := 0;
- if dsBlend25 in DrawingStyle then
- Result := Result or ILD_BLEND25;
- if dsBlend50 in DrawingStyle then
- Result := Result or ILD_BLEND50;
- if dsTransparent in DrawingStyle then
- Result := Result or ILD_TRANSPARENT
- else
- if dsMask in DrawingStyle then
- Result := Result or ILD_MASK
- {else
- Result := Result or ILD_NORMAL}; // ILD_NORMAL = 0
- end;
-
- //[function TImageList.GetHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TImageList.GetHandle: THandle;
- begin
- HandleNeeded;
- Result := FHandle;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TImageList.GetMask]
- function TImageList.GetMask: HBitmap;
- var II : TImageInfo;
- begin
- Result := 0;
- if FHandle = 0 then Exit;
- if ImageList_GetImageInfo( FHandle, 0, II ) then
- Result := II.hbmMask;
- end;
-
- {$IFDEF ASM_noVERSION}
- //[function TImageList.HandleNeeded]
- function TImageList.HandleNeeded: Boolean;
- const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
- ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24,
- ILC_COLOR32, ILC_COLORDDB );
- asm
- MOV ECX, [EAX].FHandle
- JECXZ @@make_handle
- MOV AL, 1
- RET
- @@make_handle:
- MOV ECX, [EAX].fImgWidth
- JECXZ @@ret_ECX
- MOV EDX, ECX
- MOV ECX, [EAX].fImgHeight
- JECXZ @@ret_ECX
- PUSH EBX
- XCHG EBX, EAX
-
- PUSH [EBX].FAllocBy
- PUSH 0
- MOVZX EAX, [EBX].FColors
- MOVZX EAX, byte ptr [ColorFlags+EAX]
- CMP [EBX].FMasked, 0
- JZ @@flags_ready
- {$IFDEF PARANOIA} DB $0C, $01 {$ELSE} OR AL, 1 {$ENDIF}
- @@flags_ready:
- PUSH EAX
- PUSH ECX
- PUSH EDX
- CALL ImageList_Create
- MOV [EBX].FHandle, EAX
- XCHG ECX, EAX
- POP EBX
- @@ret_ECX:
- TEST ECX, ECX
- SETNZ AL
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TImageList.HandleNeeded: Boolean;
- const ColorFlags : array[ TImageListColors ] of Byte = ( ILC_COLOR,
- {$ifndef wince}
- ILC_COLOR4, ILC_COLOR8, ILC_COLOR16, ILC_COLOR24, ILC_COLOR32,
- {$else}
- ILC_COLOR, ILC_COLOR, ILC_COLOR, ILC_COLOR, ILC_COLOR,
- {$endif wince}
- ILC_COLORDDB, 0 );
- var Flags : DWord;
- begin
- Result := True;
- if FHandle <> 0 then Exit;
- Result := False;
- if ImgWidth = 0 then Exit;
- if ImgHeight = 0 then Exit;
- Flags := ColorFlags[ FColors ];
- if Masked then
- Flags := Flags or ILC_MASK;
- FHandle := ImageList_Create( ImgWidth, ImgHeight, Flags, 0, FAllocBy );
- if fBkColor <> clNone then
- SetBkColor( fBkColor );
- Result := FHandle <> 0;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TImageList.ImgRect]
- function TImageList.ImgRect(Idx: Integer): TRect;
- var II : TImageInfo;
- begin
- Result := MakeRect( 0, 0, 0, 0 );
- if FHandle = 0 then Exit;
- if ImageList_GetImageInfo( FHandle, Idx, II ) then
- Result := II.rcImage;
- end;
-
- {$IFDEF ASM_noVERSION_UNICODE}
- //[function TImageList.LoadBitmap]
- function TImageList.LoadBitmap(ResourceName: PChar;
- TranspColor: TColor): Boolean;
- asm
- PUSH EBX
- XCHG EBX, EAX
- XCHG EAX, ECX //TranspColor
- PUSH EDX
- CMP EAX, clNone
- JNE @@2rgb
- OR EAX, -1
- JMP @@tranColorReady
- @@2rgb:
- CALL Color2RGB
- @@tranColorReady:
- POP EDX
- PUSH EAX
- PUSH [EBX].fAllocBy
- PUSH [EBX].fImgWidth
- PUSH EDX
- PUSH [hInstance]
- CALL ImageList_LoadBitmap
- TEST EAX, EAX
- JZ @@exit
- XCHG EDX, EAX
- XCHG EAX, EBX
- CALL SetHandle
- MOV AL, 1
- @@exit: POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TImageList.LoadBitmap(ResourceName: PKOLChar;
- TranspColor: TColor): Boolean;
- var NewHandle : THandle;
- TranColr: TColor;
- begin
- TranColr := TranspColor;
- if TranColr = clNone then TranColr := TColor( CLR_NONE )
- else TranColr := Color2RGB( TranColr );
- NewHandle := ImageList_LoadBitmap( hInstance, pointer(ResourceName),
- ImgWidth, AllocBy, TranColr );
- //ImageList_GetIconSize( NewHandle, fImgWidth, fImgHeight );
- Result := NewHandle <> 0;
- if Result then
- Handle := NewHandle;
- ImageList_GetIconSize( fHandle, FImgWidth, FImgHeight );
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TImageList.LoadFromFile]
- function TImageList.LoadFromFile(FileName: PKOLChar; TranspColor: TColor;
- ImgType: TImageType): Boolean;
- const ImgTypes:array[ TImageType ] of DWord = ( IMAGE_BITMAP, IMAGE_ICON, IMAGE_CURSOR );
- var NewHandle : THandle;
- TranspFlag : DWord;
- begin
- TranspFlag := 0;
- if TranspColor <> clNone then
- TranspFlag := LR_LOADTRANSPARENT;
- NewHandle := ImageList_LoadImage( hInstance, pointer(FileName), ImgWidth, AllocBy,
- Color2RGB( TranspColor ), ImgTypes[ ImgType ],
- LR_LOADFROMFILE or TranspFlag );
- Result := NewHandle <> 0;
- if Result then
- Handle := NewHandle;
- end;
-
- //*
- //[function TImageList.LoadSystemIcons]
- function TImageList.LoadSystemIcons(SmallIcons: Boolean): Boolean;
- var NewHandle : THandle;
- FileInfo : TSHFileInfo;
- Flags : DWord;
- begin
- {$ifdef win32}OleInit;{$endif}
- Flags := SHGFI_SYSICONINDEX;
- if SmallIcons then
- Flags := Flags or SHGFI_SMALLICON;
- NewHandle := {$IFDEF UNICODE_CTRLS} SHGetFileInfoW {$ELSE} SHGetFileInfoA {$ENDIF}
- ( '', 0, FileInfo, Sizeof( FileInfo ), Flags );
- Result := NewHandle <> 0;
- if Result then
- begin
- Handle := NewHandle;
- FShareImages := True;
- end;
- end;
-
- //*
- //[function TImageList.Merge]
- function TImageList.Merge(Idx: Integer; ImgList2: PImageList; Idx2, X,
- Y: Integer): PImageList;
- var L : THandle;
- begin
- Result := nil;
- //if FHandle = 0 then Exit;
- L := ImageList_Merge( FHandle, Idx, ImgList2.Handle, Idx2, X, Y );
- if L <> 0 then
- begin
- Result := NewImageList( fControl );
- Result.Handle := L;
- end;
- end;
-
- //*
- //[function TImageList.Replace]
- function TImageList.Replace(Idx: Integer; Bmp, Msk: HBitmap): Boolean;
- begin
- Result := False;
- if FHandle = 0 then Exit;
- Result := ImageList_Replace( FHandle, Idx, Bmp, Msk );
- end;
-
- //*
- //[function TImageList.ReplaceIcon]
- function TImageList.ReplaceIcon(Idx: Integer; Ico: HIcon): Boolean;
- begin
- Result := False;
- if FHandle = 0 then Exit;
- Result := ImageList_ReplaceIcon( FHandle, Idx, Ico ) >= 0;
- end;
-
- //*
- //[procedure TImageList.SetAllocBy]
- procedure TImageList.SetAllocBy(const Value: Integer);
- begin
- if FHandle <> 0 then Exit;
- // AllocBy can be changed only before adding images
- // and creating image list handle
- FAllocBy := Value;
- end;
-
- //*
- //[procedure TImageList.SetBkColor]
- procedure TImageList.SetBkColor(const Value: TColor);
- begin
- fBkColor := Value;
- if fHandle <> 0 then
- ImageList_SetBkColor( FHandle, Color2RGB( Value ) );
- end;
-
- //*
- //[procedure TImageList.SetColors]
- procedure TImageList.SetColors(const Value: TImageListColors);
- begin
- if FHandle <> 0 then Exit;
- FColors := Value;
- end;
-
- //[procedure TImageList.SetHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TImageList.SetHandle(const Value: THandle);
- begin
- if FHandle = Value then Exit;
- if (FHandle <> 0) and not FShareImages then
- ImageList_Destroy( FHandle );
- FHandle := Value;
- if FHandle <> 0 then
- ImageList_GetIconSize( FHandle, FImgWidth, FImgHeight )
- else
- begin
- FImgWidth := 0;
- FImgHeight := 0;
- end;
- //FBkColor := ImageList_GetBkColor( FHandle );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TImageList.SetImgHeight]
- procedure TImageList.SetImgHeight(const Value: Integer);
- begin
- if FHandle <> 0 then Exit;
- FImgHeight := Value;
- end;
-
- //[procedure TImageList.SetImgWidth]
- procedure TImageList.SetImgWidth(const Value: Integer);
- begin
- if FHandle <> 0 then Exit;
- FImgWidth := Value;
- end;
-
- //[procedure TImageList.SetMasked]
- procedure TImageList.SetMasked(const Value: Boolean);
- begin
- if FHandle <> 0 then Exit;
- FMasked := Value;
- end;
-
- //*
- //[function TImageList.GetOverlay]
- function TImageList.GetOverlay(Idx: TImgLOVrlayIdx): Integer;
- begin
- Result := fOverlay[ Idx ];
- end;
-
- //[procedure TImageList.SetOverlay]
- procedure TImageList.SetOverlay(Idx: TImgLOVrlayIdx; const Value: Integer);
- begin
- if ImageList_SetOverlayImage( fHandle, Value, Idx ) then
- fOverlay[ Idx ] := Value;
- end;
-
- //[procedure TImageList.StretchDraw]
- procedure TImageList.StretchDraw(Idx: Integer; DC: HDC; const Rect: TRect);
- begin
- if FHandle = 0 then Exit;
- ImageList_DrawEx( FHandle, Idx, DC, Rect.Left, Rect.Top,
- Rect.Right- Rect.Left, Rect.Bottom-Rect.Top,
- BkColor, BlendColor, GetDrawStyle );
- end;
-
- //*
- //[function GetImgListSize]
- function GetImgListSize( Sender: PControl; Size: Integer ): PImageList;
- begin
- if Size > 16 then
- Result := Sender.fCtlImageListNormal
- else
- Result := Sender.fCtlImageListSml;
- if Result <> nil then
- begin
- if Result.fImgWidth = 0 then
- Result.ImgWidth := Size;
- if Result.fImgHeight = 0 then
- Result.ImgHeight := Size;
- //if (Result.FImgWidth <> Size) or (Result.FImgHeight <> Size) then
- // Result := nil;
- end;
- if Result = nil then
- begin
- Result := Sender.fImageList;
- while Result <> nil do
- begin
- if (Result.FImgWidth = Size) and (Result.FImgHeight = Size) then
- break;
- Result := Result.fNext;
- end;
- end;
- end;
-
- //*
- //[function TControl.GetImgListIdx]
- function TControl.GetImgListIdx(const Index: Integer): PImageList;
- begin
- if Index <> 0 then
- Result := GetImgListSize( @Self, Index )
- else
- begin
- Result := fCtlImgListState;
- if Result = nil then
- begin
- Result := fImageList;
- while Result <> nil do
- begin
- if (Result <> GetImgListIdx( 16 )) and (Result <> GetImgListIdx( 32 )) then
- break;
- Result := Result.fNext;
- end;
- end;
- end;
- end;
-
- //*
- //[procedure TControl.SetImgListIdx]
- procedure TControl.SetImgListIdx(const Index: Integer;
- const Value: PImageList);
- begin
-
- if Value <> nil then
- begin
- if Index <> 0 then
- if (Value.ImgWidth = 0) or (Value.ImgHeight = 0) then
- begin
- Value.ImgWidth := Index;
- Value.ImgHeight := Index;
- end;
- end;
-
- case Index of
- 32: fCtlImageListNormal := Value;
- 16: fCtlImageListSml := Value;
- else fCtlImgListState := Value;
- end;
- ApplyImageLists2Control( @Self );
- end;
-
- { -- list view -- }
-
- //[function WndProcEndLabelEdit]
- function WndProcEndLabelEdit( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var NMhdr: PNMHdr;
- LVDisp: PLVDispInfo;
- Flag: Boolean;
- begin
- Result := False;
- if Msg.message = WM_NOTIFY then
- begin
- NMHdr := Pointer( Msg.lParam );
- case LongInt(NMHdr.code) of
- LVN_ENDLABELEDIT:
- begin
- LVDisp := Pointer( Msg.lParam );
- Result := True;
- if LVDisp.item.pszText = nil then Exit;
- Rslt := 1;
- if assigned( Self_.fOnEndEditLVItem ) then
- begin
- Flag := Self_.fOnEndEditLVItem( Self_, LVDisp.item.iItem,
- LVDisp.item.iSubItem, LVDisp.item.pszText );
- if Flag then Rslt := 1
- else Rslt := 0;
- end;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnEndEditLVItem]
- procedure TControl.SetOnEndEditLVItem(const Value: TOnEditLVItem);
- begin
- fOnEndEditLVITem := Value;
- AttachProc( WndProcEndLabelEdit );
- end;
-
- //*
- //[procedure TControl.LVColAdd]
- procedure TControl.LVColAdd(const aText: KOLString; aalign: TTextAlign;
- aWidth: Integer);
- begin
- LVColInsert( fLVColCount, aText, aalign, aWidth );// 21.10.2001
- end;
-
- //****************** changed by Mike Gerasimov
- //[procedure TControl.LVColInsert]
- procedure TControl.LVColInsert(ColIdx: Integer; const aText: KOLString;
- aAlign: TTextAlign; aWidth: Integer);
- var LVColData: TLVColumn;
- begin
- LVColData.mask := LVCF_FMT or LVCF_TEXT;
- if ImageListSmall <> nil then
- LVColData.mask := LVColData.mask; // or LVCF_IMAGE ;
- LVColData.iImage := -1;
- LVColData.fmt := Ord( aAlign );
- if aWidth < 0 then
- begin
- aWidth := -aWidth;
- LVColData.fmt := LVColData.fmt or LVCFMT_BITMAP_ON_RIGHT;
- end;
- LVColData.cx := aWidth;
- if aWidth > 0 then
- LVColData.mask := LVColData.mask or LVCF_WIDTH;
- LVColData.pszText := PKOL_Char( aText );
- if Perform( LVM_INSERTCOLUMN, ColIdx, Integer( @LVColData ) ) >= 0 then
- Inc( fLVColCount );
- end;
-
- //[function TControl.GetLVColText]
- function TControl.GetLVColText(Idx: Integer): KOLString;
- var Buf: array[ 0..4095 ] of KOLChar;
- LC: TLVColumn;
- begin
- LC.mask := LVCF_TEXT;
- LC.pszText := @ Buf[ 0 ];
- LC.cchTextMax := 4096;
- Buf[ 0 ] := #0;
- Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
- Result := Buf;
- end;
-
- //[procedure TControl.SetLVColText]
- procedure TControl.SetLVColText(Idx: Integer; const Value: KOLString);
- var LC: TLVColumn;
- begin
- FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
- LC.mask := LVCF_TEXT;
- LC.pszText := '';
- if Value <> '' then
- LC.pszText := @ Value[ 1 ];
- Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
- end;
-
- //[function TControl.GetLVColalign]
- function TControl.GetLVColalign(Idx: Integer): TTextAlign;
- const Formats: array[ 0..2 ] of TTextAlign = ( taLeft, taRight, taCenter );
- var LC: TLVColumn;
- begin
- FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
- LC.mask := LVCF_FMT;
- Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
- Result := Formats[ LC.fmt and LVCFMT_JUSTIFYMASK ];
- end;
-
- //[procedure TControl.SetLVColalign]
- procedure TControl.SetLVColalign(Idx: Integer; const Value: TTextAlign);
- const FormatFlags: array[ TTextAlign ] of BYTE = ( LVCFMT_LEFT, LVCFMT_RIGHT,
- LVCFMT_CENTER );
- var LC: TLVColumn;
- begin
- FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
- LC.mask := LVCF_FMT;
- Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
- LC.fmt := LC.fmt and not LVCFMT_JUSTIFYMASK or FormatFlags[ Value ];
- Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
- end;
-
- //[function TControl.GetLVColEx]
- function TControl.GetLVColEx(Idx: Integer; const Index: Integer): Integer;
- var LC: TLVColumn;
- begin
- FillChar( LC, Sizeof( LC ), #0 ); {Alexey (Lecha2002)}
- LC.mask := LoWord( Index );
- Perform( LVM_GETCOLUMN, Idx, Integer( @ LC ) );
- Result := PDWORD( cardinal( @ LC ) + HiWord( Index ) )^;
- end;
-
- //********************** changed by Mike Gerasimov
- //[procedure TControl.SetLVColEx]
- procedure TControl.SetLVColEx(Idx: Integer; const Index: Integer;
- const Value: Integer);
- var LC: TLVColumn;
- begin
- FillChar(LC,SizeOf(LC),#0); // Added Line
- LC.mask := LoWord( Index );
- {$ifdef win32}
- if HiWord( Index ) = 24 then // Added Line
- begin // Added Line
- LC.mask := LC.mask or LVCF_FMT; // Added Line
- if Value <>-1 then // Added Line
- LC.fmt := LC.fmt or LVCFMT_IMAGE or LVCFMT_COL_HAS_IMAGES // Added Line
- else LC.mask := LC.mask and not LVCF_IMAGE; // + by non
- end;
- {$endif win32}
- if (value<>-1)or(HiWord( Index )<>24) then // + by non
- PDWORD( cardinal( @ LC ) + HiWord( Index ) )^ := Value;
- Perform( LVM_SETCOLUMN, Idx, Integer( @ LC ) );
- end;
-
- //*
- //[function TControl.LVAdd]
- function TControl.LVAdd(const aText: KOLString; ImgIdx: Integer;
- State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
- Data: DWORD): Integer;
- begin
- Result := LVInsert( MaxInt {Count}, aText, ImgIdx, State, StateImgIdx, OverlayImgIdx, Data );
- end;
-
- //*
- //[function TControl.LVInsert]
- function TControl.LVInsert(Idx: Integer; const aText: KOLString;
- ImgIdx: Integer; State: TListViewItemState; StateImgIdx, OverlayImgIdx: Integer;
- Data: DWORD): Integer;
- const
- LVM_REDRAWITEMS = LVM_FIRST + 21;
- var LVI: TLVItem;
- begin
- LVI.mask := LVIF_TEXT or LVIF_IMAGE or LVIF_PARAM or LVIF_STATE;
- LVI.iItem := Idx;
- LVI.iSubItem := 0;
- LVI.state := 0;
- if lvisBlend in State then
- LVI.state := LVIS_CUT;
- if lvisHighlight in State then
- LVI.state := LVI.state or LVIS_DROPHILITED;
- if lvisFocus in State then
- LVI.state := LVI.state or LVIS_FOCUSED;
- if lvisSelect in State then
- LVI.state := LVI.state or LVIS_SELECTED;
- LVI.stateMask := $FFFF;
- if StateImgIdx <> 0 then
- LVI.state := LVI.state or ((cardinal(StateImgIdx) and $F) shl 12);
- if OverlayImgIdx <> 0 then
- LVI.state := LVI.state or ((cardinal(OverlayImgIdx) and $F) shl 8);
- LVI.pszText := PKOL_Char( aText );
- LVI.iImage := ImgIdx;
- LVI.lParam := Data;
- Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
- //Perform( LVM_REDRAWITEMS, Idx, Idx );
- end;
-
- //*
- //[procedure TControl.LVSetItem]
- procedure TControl.LVSetItem(Idx, Col: Integer; const aText: KOLString;
- ImgIdx: Integer; State: TListViewItemState; StateImgIdx,
- OverlayImgIdx: Integer; Data: DWORD);
- var LVI: TLVItem;
- I: Integer;
- begin
- if Col = 0 then
- LVI.mask := LVIF_TEXT or LVIF_STATE or LVIF_PARAM
- else
- LVI.mask := LVIF_TEXT;
- if ImgIdx <> I_SKIP then
- LVI.mask := LVI.mask or LVIF_IMAGE;
- if ImgIdx < I_SKIP then
- LVI.mask := LVIF_TEXT;
- LVI.iItem := Idx;
- LVI.iSubItem := Col;
- LVI.state := 0;
- if lvisBlend in State then
- LVI.state := LVIS_CUT;
- if lvisHighlight in State then
- LVI.state := LVI.state or LVIS_DROPHILITED;
- if lvisFocus in State then
- LVI.state := LVI.state or LVIS_FOCUSED;
- if lvisSelect in State then
- LVI.state := LVI.state or LVIS_SELECTED;
- LVI.stateMask := $FFFF;
- if StateImgIdx <> 0 then
- LVI.state := LVI.state or ((cardinal(StateImgIdx) and $F) shl 12);
- if StateImgIdx < 0 {= I_SKIP} then
- LVI.stateMask := $F0FF;
- if OverlayImgIdx <> 0 then
- LVI.state := LVI.state or ((cardinal(OverlayImgIdx) and $F) shl 8);
- if OverlayImgIdx < 0 {=I_SKIP} then
- LVI.stateMask := LVI.stateMask and $FFF;
- LVI.pszText := PKOL_Char( aText );
- LVI.iImage := ImgIdx;
- LVI.lParam := Data;
- I := Perform( LVM_SETITEM, 0, Integer( @LVI ) );
- if (I = 0) and (Col = 0) then
- Assert( False, 'Can not set item ' );
- end;
-
- //*
- //[procedure LVGetItem]
- procedure LVGetItem( Sender: PControl; Idx, Col: Integer; var LVI: TLVItem;
- TextBuf: PKOL_Char; TextBufSize: Integer );
- begin
- LVI.mask := LVIF_STATE or LVIF_PARAM or LVIF_IMAGE;
- if Col > 0 then
- if not (lvoSubItemImages in Sender.fLVOptions) then
- LVI.mask := LVIF_STATE or LVIF_PARAM;
- LVI.iItem := Idx;
- LVI.iSubItem := Col;
- LVI.pszText := TextBuf;
- LVI.cchTextMax := TextBufSize;
- if TextBufSize <> 0 then
- LVI.mask := LVI.mask or LVIF_TEXT;
- Sender.Perform( LVM_GETITEM, 0, Integer( @LVI ) );
- end;
-
- //[function TControl.LVGetItemImgIdx]
- function TControl.LVGetItemImgIdx(Idx: Integer): Integer;
- var LVI: TLVItem;
- begin
- LVI.iImage := -1;//= Result if image is not assigned {Andrzej Kubaszek}
- LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
- Result := LVI.iImage;
- end;
-
- //[procedure TControl.LVSetItemImgIdx]
- procedure TControl.LVSetItemImgIdx(Idx: Integer; const Value: Integer);
- var LVI: TLVItem;
- begin
- LVGetItem( @Self, Idx, 0, LVI, nil, 0 );
- LVI.iImage := Value;
- Perform( LVM_SETITEM, 0, Integer( @LVI ) );
- end;
-
- //[function TControl.LVGetItemText]
- function TControl.LVGetItemText(Idx, Col: Integer): KOLString;
- var LVI: TLVItem;
- TextBuf: PKOL_Char;
- BufSize: Integer;
- begin
- BufSize := 0;
- TextBuf := nil;
- repeat
- if TextBuf <> nil then
- FreeMem( TextBuf );
- BufSize := BufSize * 2 + 100; // to vary in asm version
- GetMem( TextBuf, BufSize * Sizeof( KOLChar ) );
- TextBuf[ 0 ] := #0;
- LVGetItem( @Self, Idx, Col, LVI, TextBuf, BufSize );
- until Integer({$IFDEF UNICODE_CTRLS} WStrLen {$ELSE} StrLen {$ENDIF}
- ( PKOLChar( TextBuf ) )) < BufSize - 1;
- Result := TextBuf;
- FreeMem( TextBuf );
- end;
-
- //*
- //[procedure TControl.LVSetItemText]
- procedure TControl.LVSetItemText(Idx, Col: Integer; const Value: KOLString);
- var LVI: TLVItem;
- begin
- LVI.iSubItem := Col;
- LVI.pszText := PKOL_Char( Value );
- Perform( LVM_SETITEMTEXT, Idx, Integer( @LVI ) );
- end;
-
- //[procedure TControl.LVColDelete]
- procedure TControl.LVColDelete(ColIdx: Integer);
- begin
- Perform( LVM_DELETECOLUMN, ColIdx, 0 );
- if fLVColCount > 0 then
- Dec( fLVColCount );
- end;
-
- //[procedure TControl.SetLVOptions]
- procedure TControl.SetLVOptions(const Value: TListViewOptions);
- begin
- if fLVOptions = Value then Exit;
- fLVOptions := Value;
- ApplyImageLists2ListView( @Self );
- PostMessage( fHandle, WM_SIZE, 0, 0 ); // to restore scrollers (otherwise its are lost)
- end;
-
- //[procedure TControl.SetLVStyle]
- procedure TControl.SetLVStyle(const Value: TListViewStyle);
- begin
- if fLVStyle = Value then Exit;
- fLVStyle := Value;
- ApplyImageLists2ListView( @Self );
- end;
-
- //[function TControl.Perform]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Perform(msgcode: DWORD; wParam, lParam: Integer): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- {$IFDEF INPACKAGE}
- Log( '->TControl.Perform' );
- TRY
- {$ENDIF INPACKAGE}
- Result := SendMessage( GetWindowHandle, msgcode, wParam, lParam );
- {$IFDEF INPACKAGE}
- LogOK;
- FINALLY
- Log( '<-TControl.Perform' );
- END;
- {$ENDIF INPACKAGE}
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.Postmsg]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.Postmsg(msgcode: DWORD; wParam, lParam: Integer): Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result := PostMessage( GetWindowHandle, msgcode, wParam, lParam );
- end;
- {$ENDIF ASM_VERSION}
-
- {$ENDIF WIN_GDI}
- //[function TControl.GetChildCount]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.GetChildCount: Integer;
- begin
- Result := fChildren.fCount;
- end;
- {$ENDIF ASM_VERSION}
- {$IFDEF WIN_GDI}
-
- //[procedure TControl.LVDelete]
- procedure TControl.LVDelete(Idx: Integer);
- begin
- Perform( LVM_DELETEITEM, Idx, 0 );
- end;
-
- //[procedure TControl.LVEditItemLabel]
- procedure TControl.LVEditItemLabel(Idx: Integer);
- begin
- Perform( LVM_EDITLABEL, Idx, 0 );
- end;
-
- //*
- //[function TControl.LVItemRect]
- function TControl.LVItemRect(Idx: Integer; Part: TGetLVItemPart): TRect;
- const Parts: array[ TGetLVItemPart ] of Byte = (
- LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL, LVIR_SELECTBOUNDS );
- begin
- Result := MakeRect( Parts[ Part ], 0, 0, 0 );
- if Perform( LVM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
- begin
- //ShowMessage( SysErrorMessage( GetLastError ) );
- Result := MakeRect( 0, 0, 0, 0 );
- end;
- end;
-
- //[function TControl.LVSubItemRect]
- function TControl.LVSubItemRect(Idx, ColIdx: Integer): TRect;
- var Hdr: HWnd;
- R, R1: TRect;
- ClassNameBuf: array[ 0..31 ] of KOLChar;
- HdItem: THDItem;
- begin
- Result.Top := ColIdx; // + 1; error in MSDN ?
- Result.Left := LVIR_BOUNDS;
- if Perform( LVM_GETSUBITEMRECT, Idx, Integer( @Result ) ) <> 0 then
- Exit;
- Result := MakeRect( 0, 0, 0, 0 );
- if ColIdx > 0 then R := LVSubItemRect( Idx, ColIdx - 1 )
- else R := LVItemRect( Idx, lvipBounds );
- if (R.Left = 0) and (R.Right = 0) and
- (R.Top = 0) and (R.Bottom = 0) then Exit;
- Hdr := GetWindow( GetWindowHandle, GW_CHILD );
- if Hdr <> 0 then
- begin
- if GetClassName( Hdr, ClassNameBuf, 32 ) > 0 then
- if ClassNameBuf = 'SysHeader32' then
- begin
- if ColIdx > 0 then R.Left := R.Right
- else R.Left := 0;
- R1.Top := 0; R1.Left := 0;
- Windows.ClientToScreen( Hdr,{$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
- Windows.ScreenToClient( fHandle, {$IFDEF FPC} PPoint( @ R1.Left )^ {$ELSE} R1.TopLeft {$ENDIF} );
- R1 := R;
- HdItem.Mask := HDI_WIDTH;
- if SendMessage( Hdr, HDM_GETITEM, ColIdx, Integer( @HdItem ) ) = 0 then Exit;
- R1.Right := R1.Left + HdItem.cxy;
- Result := R1;
- end;
- end;
- end;
-
- //*
- //[function TControl.LVGetItemPos]
- function TControl.LVGetItemPos(Idx: Integer): TPoint;
- begin
- Perform( LVM_GETITEMPOSITION, Idx, Integer( @Result ) );
- end;
-
- //*
- //[procedure TControl.LVSetItemPos]
- procedure TControl.LVSetItemPos(Idx: Integer; const Value: TPoint);
- begin
- Perform( LVM_SETITEMPOSITION32, Idx, Integer( @Value ) );
- end;
-
- //*
- //[function TControl.LVItemAtPos]
- function TControl.LVItemAtPos(X, Y: Integer): Integer;
- var Dummy: TWherePosLVItem;
- begin
- Result := LVItemAtPosEx( X, Y, Dummy );
- end;
-
- //*
- //[function TControl.LVItemAtPosEx]
- function TControl.LVItemAtPosEx(X, Y: Integer;
- var Where: TWherePosLVItem): Integer;
- var HTI: TLVHitTestInfo;
- begin
- HTI.pt.x := X;
- HTI.pt.y := Y;
- Perform( LVM_HITTEST, 0, Integer( @HTI ) );
- Result := HTI.iItem;
- Where := lvwpOnColumn;
- if HTI.flags = LVHT_ONITEMICON then
- Where := lvwpOnIcon
- else
- if HTI.flags = LVHT_ONITEMLABEL then
- Where := lvwpOnLabel
- else
- if HTI.flags = LVHT_ONITEMSTATEICON then
- Where := lvwpOnStateIcon
- else
- if HTI.flags = LVHT_ONITEM then
- Where := lvwpOnItem;
- end;
-
- //[procedure TControl.LVMakeVisible]
- procedure TControl.LVMakeVisible(Item: Integer; PartiallyOK: Boolean);
- begin
- if Item < 0 then Exit;
- Perform( LVM_ENSUREVISIBLE, Item, Integer( PartiallyOK ) );
- end;
-
- //*
- //[procedure TControl.LVSetColorByIdx]
- procedure TControl.LVSetColorByIdx(const Index: Integer;
- const Value: TColor);
- var MsgCode: Integer;
- ColorValue: TColor;
- begin
- MsgCode := Index + 1;
- case MsgCode of
- LVM_SETTEXTCOLOR: fTextColor := Value;
- LVM_SETTEXTBKCOLOR: fLVTextBkColor := Value;
- LVM_SETBKCOLOR: fColor := Value;
- end;
- ColorValue := Color2RGB( Value );
- Perform( MsgCode, 0, ColorValue );
- end;
-
- {$IFDEF F_P}
- //[function TControl.LVGetColorByIdx]
- function TControl.LVGetColorByIdx(const Index: Integer): TColor;
- begin
- CASE Index OF
- LVM_SETTEXTCOLOR: Result := fTextColor;
- LVM_SETTEXTBKCOLOR: Result := fLVTextBkColor;
- LVM_SETBKCOLOR: Result := fColor;
- END;
- end;
- {$ENDIF F_P}
-
- //*
- //[function TControl.GetIntVal]
- function TControl.GetIntVal(const Index: Integer): Integer;
- begin
- Result := GetItemVal( 0, Index );
- end;
-
- //*
- //[procedure TControl.SetIntVal]
- procedure TControl.SetIntVal(const Index, Value: Integer);
- begin
- SetItemVal( Value, Index, 0 );
- end;
-
- //*
- //[function TControl.GetItemVal]
- function TControl.GetItemVal(Item: Integer; const Index: Integer): Integer;
- begin
- Result := Perform( LoWord(Index), Item, 0 );
- end;
-
- //[procedure TControl.SetItemVal]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.SetItemVal(Item: Integer; const Index: Integer; const Value: Integer);
- var MsgCode: Integer;
- begin
- MsgCode := HiWord( Index );
- if MsgCode = 0 then
- MsgCode := Index + 1;
- Perform( MsgCode and $7FFF, Item, Value );
- if (MsgCode and $8000) <> 0 then
- Invalidate;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.GetSBMinMax]
- function TControl.GetSBMinMax: TPoint;
- {$IFDEF _D2}
- var X, Y: Integer;
- {$ENDIF}
- begin
- if (Handle <> 0) then begin
- {$IFDEF _D2}
- GetScrollRange(Handle, SB_CTL, X, Y);
- Result.X := X;
- Result.Y := Y;
- {$ELSE}
- GetScrollRange(Handle, SB_CTL, Result.X, Result.Y);
- {$ENDIF}
- Dec(Result.Y, SBPageSize - 1);
- end
- else
- Result := fSBMinMax;
- end;
-
- //[procedure TControl.GetSBPageSize]
- function TControl.GetSBPageSize: Integer;
- var
- SI: TScrollInfo;
- begin
- FillChar(SI, SizeOf(SI), #0);
- SI.cbSize := SizeOf(SI);
- SI.fMask := SIF_PAGE;
- SBGetScrollInfo(SI);
- Result := SI.nPage;
- end;
-
- //[procedure TControl.GetSBPosition]
- function TControl.GetSBPosition: Integer;
- begin
- Result := GetScrollPos(Handle, SB_CTL);
- end;
-
- //[procedure TControl.SetSBMax]
- procedure TControl.SetSBMax(Value: Longint);
- var
- P: TPoint;
- begin
- fSBMinMax.Y := Value;
- if (Handle <> 0) then begin
- P := SBMinMax;
- P.Y := Value;
- SBMinMax := P;
- end;
- end;
-
- //[procedure TControl.SetSBMin]
- procedure TControl.SetSBMin(Value: Longint);
- var
- P: TPoint;
- begin
- fSBMinMax.X := Value;
- if (Handle <> 0) then begin
- P := SBMinMax;
- P.X := Value;
- SBMinMax := P;
- end;
- end;
-
- //[procedure TControl.SetSBPageSize]
- procedure TControl.SetSBPageSize(Value: Integer);
- var
- SI: TScrollInfo;
- begin
- fSBPageSize := Value;
- if (Handle <> 0) then begin
- FillChar(SI, SizeOf(SI), #0);
- SI.cbSize := SizeOf(SI);
- SI.fMask := SIF_PAGE or SIF_RANGE;
- SBGetScrollInfo(SI);
- if (SI.nMax = 0) and (SI.nMin = 0) then
- SI.nMax := 1;
- SI.nMax := SI.nMax - Integer(SI.nPage) + Value;
- SI.nPage := Value;
- SBSetScrollInfo(SI);
- end;
- end;
-
- //[procedure TControl.SetSBPosition]
- procedure TControl.SetSBPosition(Value: Integer);
- begin
- fSBPosition := Value;
- if (Handle <> 0) then
- SetScrollPos(Handle, SB_CTL, Value, True);
- end;
-
- //[procedure TControl.SetSBMinMax]
- procedure TControl.SetSBMinMax(const Value: TPoint);
- begin
- GetSBMinMax;
- if (Handle <> 0) then
- SetScrollRange(Handle, SB_CTL, Value.X, Value.Y + SBPageSize - 1, True)
- else
- fSBMinMax := Value;
- end;
-
- //[procedure TControl.SBSetScrollInfo]
- function TControl.SBSetScrollInfo(const SI: TScrollInfo): Integer;
- begin
- Result := SetScrollInfo(Handle, SB_CTL, SI, True)
- end;
-
- //[procedure TControl.SBGetScrollInfo]
- function TControl.SBGetScrollInfo(var SI: TScrollInfo): Boolean;
- begin
- Result := Cardinal(GetScrollInfo(Handle, SB_CTL, SI)) <> 0;
- end;
-
- { -- OpenSaveDialog -- }
-
- //*
- //[function NewOpenSaveDialog]
- function NewOpenSaveDialog( const Title, StrtDir: KOLString;
- Options: TOpenSaveOptions ): POpenSaveDialog;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := POpenSaveDialog.Create;*){--}
- Result.FOptions := Options;
- if Options = [] then
- Result.FOptions := DefOpenSaveDlgOptions;
- Result.fOpenDialog := True;
- Result.FTitle := Title;
- Result.FInitialDir := StrtDir;
- end;
- //[END NewOpenSaveDialog]
-
- { TOpenSaveDialog }
-
- //[destructor TOpenSaveDialog.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TOpenSaveDialog.Destroy;
- begin
- FFilter := '';
- FInitialDir := '';
- FDefExtension := '';
- FFileName := '';
- FTitle := '';
- {$IFDEF OpenSaveDialog_Extended}
- TemplateName := '';
- {$ENDIF}
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TOpenSaveDialog.Execute]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TOpenSaveDialog.Execute: Boolean;
- const OpenSaveFlags: array[ TOpenSaveOption ] of Integer = (
- OFN_CREATEPROMPT,
- OFN_EXTENSIONDIFFERENT,
- OFN_FILEMUSTEXIST,
- OFN_HIDEREADONLY,
- OFN_NOCHANGEDIR,
- OFN_NODEREFERENCELINKS,
- OFN_ALLOWMULTISELECT,
- OFN_NONETWORKBUTTON,
- OFN_NOREADONLYRETURN,
- OFN_OVERWRITEPROMPT,
- OFN_PATHMUSTEXIST,
- OFN_READONLY,
- OFN_NOVALIDATE
- //{$IFDEF OpenSaveDialog_Extended}
- ,
- OFN_ENABLETEMPLATE,
- OFN_ENABLEHOOK
- //{$ENDIF}
- );
- var
- Ofn : TOpenFilename;
- Fltr : KOLString;
- TempFilename : KOLString;
-
- Function MakeFilter(s : string) : String;
- {
- format of filter for API call is following:
- 'text files'#0'*.txt'#0
- 'bitmap files'#0'*.bmp'#0#0
- }
- var Str: PChar;
- begin
- Result := s;
- if Result='' then
- exit;
- Result:=Result+#0; {Delphi string always end on #0 is this is #0#0}
- Str := PChar( Result );
- while Str^ <> #0 do
- begin
- if Str^ = '|' then
- Str^ := #0;
- Inc( Str );
- end;
- end;
-
- var m: Integer;
- begin
- Fillchar( ofn, sizeof( ofn ), 0 );
- {$ifdef wince}
- ofn.lStructSize := Sizeof( ofn );
- {$else}
- {$IFDEF OpenSaveDialog_Extended}
- if (WinVer <= wvNT) and (WinVer <> wvME) then
- ofn.lStructSize := 76
- else
- begin
- ofn.lStructSize := Sizeof( ofn );
- ofn.FlagsEx := Integer( NoPlaceBar );
- end;
- {$ELSE}
- ofn.lStructSize:= 76; //to provide correct work in Win9x
- {$ENDIF}
- {$endif wince}
- if fWnd <> 0 then
- ofn.hWndOwner := fWnd
- else
- if assigned(applet) then
- ofn.hwndOwner:=applet.Handle;
-
- ofn.hInstance:=HInstance;
-
- Fltr:=MakeFilter(FFilter);
- if Fltr <> '' then
- ofn.lpstrFilter := PKOLchar(Fltr);
- ofn.nFilterIndex := FFilterIndex;
-
- if OSAllowMultiSelect in FOptions then
- ofn.nMaxFile := High(word)-14 // by V.K. (exchanged condition)
- else
- ofn.nMaxFile := MAX_PATH+2;
-
- SetLength( TempFileName, ofn.nMaxFile );
- FillChar( TempFileName[ 1 ], ofn.nMaxFile * sizeof( KOLChar ), 0 );
- m := Min( ofn.nMaxFile, Length(fFileName) );
- {$IFDEF UNICODE_CTRLS}
- ofn.lpstrFile := PKOLchar( TempFileName );
- WStrLCopy(PWideChar(TempFileName), PWideChar(fFileName), m );
- {$ELSE}
- ofn.lpstrFile := StrLCopy(PKOLChar(TempFileName), PKOLchar(fFileName), m );
- {$ENDIF}
-
- ofn.lpstrInitialDir:=PKOLChar(FInitialDir);
- ofn.lpstrTitle := PKOLChar(FTitle);
- ofn.Flags := MakeFlags( @FOptions, OpenSaveFlags )
- or OFN_EXPLORER or OFN_LONGNAMES{$ifdef win32} or OFN_ENABLESIZING{$endif};
-
- ofn.lpstrDefExt := PKOLChar(FDefExtension);
- ofn.lCustData := integer(@self);
- {$ifdef win32}
- {$IFDEF OpenSaveDialog_Extended}
- ofn.lpTemplateName := PKOLChar( TemplateName );
- ofn.lpfnHook := HookProc;
- {$ELSE}
- ofn.lpTemplateName := nil;
- ofn.lpfnHook := nil;
- {$ENDIF}
- {$endif win32}
- if fOpenDialog then
- result := GetOpenFileName(POpenFileName( @ofn )^)
- else
- result := GetSaveFileName(POpenFileName( @ofn )^);
- if result then begin
- fFilterIndex := ofn.nFilterIndex; // by Vadim
- fOpenReadOnly := OFN_READONLY and ofn.Flags <> 0; // by ECM (in my redaction)
- if OSAllowMultiSelect in foptions then begin
- FFileName := copy(TempFileName, 1, pos(#0#0, tempfilename)-1);
- while pos(#0, ffilename) > 0 do begin
- FFilename[pos(#0, ffilename)]:=#13;
- end;
- end else
- FFileName := copy(tempFileName, 1, pos(#0, TempFilename)
- -1 // by X.Y.B.
- );
- end else
- FFilename:='';
- end;
- {$ENDIF ASM_VERSION}
-
- {$ifdef wince}
- {$define read_implementation}
- {$I KOLCEOpenDir.inc}
- {$undef read_implementation}
- {$else}
- { -- OpenDirDialog -- }
-
- //*
- //[function NewOpenDirDialog]
- function NewOpenDirDialog( const Title: KOLString; Options: TOpenDirOptions ):
- POpenDirDialog;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := POpenDirDialog.Create;*){--}
- Result.FOptions := [ odOnlySystemDirs ];
- if Options <> [] then
- Result.FOptions := Options;
- Result.FTitle := Title;
- end;
- //[END NewOpenDirDialog]
-
- { TOpenDirDialog }
-
- //[destructor TOpenDirDialog.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TOpenDirDialog.Destroy;
- begin
- FTitle := '';
- FInitialPath := '';
- FStatusText := '';
- inherited;
- end;
- {$ENDIF ASM_VERSION}
- {$ifdef win32}
- type
- PSHItemID = ^TSHItemID;
- TSHItemID = {$ifndef wince}packed{$endif} record
- cb: Word; { Size of the ID (including cb itself) }
- abID: array[0..0] of Byte; { The item ID (variable length) }
- end;
-
- PItemIDList = ^TItemIDList;
- TItemIDList = record
- mkid: TSHItemID;
- end;
-
- PBrowseInfo = ^TBrowseInfo;
- TBrowseInfoA = record
- hwndOwner: HWND;
- pidlRoot: PItemIDList;
- pszDisplayName: PChar; { Return display name of item selected. }
- lpszTitle: PChar; { text to go in the banner over the tree. }
- ulFlags: UINT; { Flags that control the return stuff }
- lpfn: Pointer; //TFNBFFCallBack;
- lParam: LPARAM; { extra info that's passed back in callbacks }
- iImage: Integer; { output var: where to return the Image index. }
- end;
- TBrowseInfoW = record
- hwndOwner: HWND;
- pidlRoot: PItemIDList;
- pszDisplayName: PWideChar; { Return display name of item selected. }
- lpszTitle: PWideChar; { text to go in the banner over the tree. }
- ulFlags: UINT; { Flags that control the return stuff }
- lpfn: Pointer; //TFNBFFCallBack;
- lParam: LPARAM; { extra info that's passed back in callbacks }
- iImage: Integer; { output var: where to return the Image index. }
- end;
- TBrowseInfo = {$IFDEF UNICODE_CTRLS} TBrowseInfoW {$ELSE} TBrowseInfoA {$ENDIF};
-
- //[API SHXXXXXXXXXX]
- function SHBrowseForFolderA(var lpbi: TBrowseInfoA): PItemIDList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHBrowseForFolderA';
- {$IFDEF UNICODE_CTRLS}
- function SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHBrowseForFolderW';
- {$ENDIF UNICODE_CTRLS}
- function SHGetPathFromIDListA(pidl: PItemIDList; pszPath: PChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHGetPathFromIDListA';
- {$IFDEF UNICODE_CTRLS}
- function SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PKOLChar): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'shell32.dll' name 'SHGetPathFromIDListW';
- {$ENDIF UNICODE_CTRLS}
- procedure CoTaskMemFree(pv: Pointer); {$ifdef wince}cdecl{$else}stdcall{$endif}; external 'ole32.dll'
- name 'CoTaskMemFree';
-
- const
- BIF_RETURNONLYFSDIRS = $0001; { For finding a folder to start document searching }
- BIF_DONTGOBELOWDOMAIN = $0002; { For starting the Find Computer }
- BIF_STATUSTEXT = $0004;
- BIF_RETURNFSANCESTORS = $0008;
- BIF_EDITBOX = $0010;
- BIF_VALIDATE = $0020; { insist on valid result (or CANCEL) }
- BIF_NEWDIALOGSTYLE = $0040; { Use the new dialog layout with the ability to resize }
- { Caller needs to call OleInitialize() before using this API (c) JVCL }
- BIF_BROWSEFORCOMPUTER = $1000; { Browsing for Computers. }
- BIF_BROWSEFORPRINTER = $2000; { Browsing for Printers }
- BIF_BROWSEINCLUDEFILES = $4000; { Browsing for Everything }
-
- BFFM_INITIALIZED = 1;
- BFFM_SELCHANGED = 2;
-
- BFFM_SETSTATUSTEXT = WM_USER + 100;
- BFFM_ENABLEOK = WM_USER + 101;
- BFFM_SETSELECTION = WM_USER + 102;
- {$endif win32}
-
- {$IFDEF ASM_UNICODE} // WndOwner
- //[function TOpenDirDialog.Execute]
- function TOpenDirDialog.Execute: Boolean;
- asm
- PUSH EBX
- XCHG EBX, EAX
-
- XOR ECX, ECX
- PUSH ECX // prepare iImage = 0
- PUSH EBX // prepare lParam = @Self
- PUSH [EBX].FCallBack // prepare lpfn = FCallBack
- LEA EAX, [EBX].FOptions
- MOV EDX, Offset[@@FlagsArray]
- MOV CL, 8
- CALL MakeFlags
- PUSH EAX // prepare ulFlags = Options
- PUSH [EBX].FTitle // prepare lpszTitle
- LEA EAX, [EBX].FBuf
- PUSH EAX // prepare pszDisplayName
- PUSH 0 // prepare pidlRoot
- MOV ECX, [EBX].fWnd
- INC ECX
- LOOP @@1
- MOV ECX, Applet
- JECXZ @@1
- MOV ECX, [ECX].TControl.fHandle
- @@1: PUSH ECX // prepare hwndOwner
-
- PUSH ESP
- CALL SHBrowseForFolderA
- ADD ESP, 32
- TEST EAX, EAX
- JZ @@exit
-
- PUSH EAX
-
- LEA EDX, [EBX].FBuf
- PUSH EDX
- PUSH EAX
- CALL SHGetPathFromIDListA
-
- CALL CoTaskMemFree
-
- MOV AL, 1
- JMP @@fin
-
- @@FlagsArray:
- DD BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN
- DD BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT
- DD BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE
-
- @@exit: XOR EAX, EAX
- @@fin:
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TOpenDirDialog.Execute: Boolean;
- const FlagsArray: array[ TOpenDirOption ] of Integer =
- ( BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,
- BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,
- BIF_BROWSEINCLUDEFILES, BIF_EDITBOX, BIF_NEWDIALOGSTYLE );
- var BI : TBrowseInfo;
- Browse : PItemIdList;
- begin
- Result := False;
- if WndOwner <> 0 then
- BI.hwndOwner := WndOwner
- else
- if assigned( Applet ) then
- BI.hwndOwner := Applet.Handle
- else
- BI.hwndOwner := 0;
- BI.pidlRoot := nil;
- BI.pszDisplayName := @FBuf[ 0 ];
- BI.lpszTitle := PKOLChar( Title );
- BI.ulFlags := MakeFlags( @FOptions, FlagsArray );
- BI.lpfn := FCallBack;
- BI.lParam := Integer( @Self );
- Browse := {$IFDEF UNICODE_CTRLS} SHBrowseForFolderW {$ELSE} SHBrowseForFolderA {$ENDIF}
- ( BI );
- if Browse <> nil then
- begin
- {$IFDEF UNICODE_CTRLS}SHGetPathFromIDListW{$ELSE} SHGetPathFromIDListA{$ENDIF}( Browse, @FBuf[ 0 ] );
- CoTaskMemFree( Browse );
- Result := True;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TOpenDirDialog.GetInitialPath]
- function TOpenDirDialog.GetInitialPath: KOLString;
- begin
- Result := IncludeTrailingPathDelimiter( fInitialPath );
- end;
-
- //[function TOpenDirDialog.GetPath]
- function TOpenDirDialog.GetPath: KOLString;
- begin
- Result := FBuf;
- end;
-
- //[FUNCTION OpenDirSelChangeCallBack]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function OpenDirSelChangeCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ):
- Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var _Self_: POpenDirDialog;
- EnableOK: Integer;
- begin
- _Self_ := Pointer( lpData );
- if assigned( _Self_.FOnSelChanged ) then
- begin
- {$IFDEF UNICODE_CTRLS} SHGetPathFromIDListW {$ELSE} SHGetPathFromIDListA {$ENDIF}( PItemIDList( lParam ), @ _Self_.FBuf[ 0 ] );
- EnableOK := 0;
- _Self_.FOnSelChanged( _Self_, _Self_.FBuf, EnableOK,
- KOL_String( KOLString( _Self_.FStatusText ) ) );
- SendMessage( Wnd, BFFM_ENABLEOK, 0, EnableOK );
- if _Self_.FStatusText <> '' then
- SendMessage( Wnd, BFFM_SETSTATUSTEXT, 0, Integer( PKOLChar( _Self_.FStatusText ) ) );
- end;
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
- //[END OpenDirSelChangeCallBack]
-
- {$IFDEF ASM_LOCAL} {$UNDEF ASM_LOCAL} {$ENDIF}
- {$IFNDEF NEW_OPEN_DIR_STYLE_EX}
- {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
- {$ENDIF}
-
- //[FUNCTION OpenDirCallBack]
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- function OpenDirCallBack( Wnd: HWnd; Msg: DWORD; lParam, lpData: LParam ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- {$IFDEF NEW_OPEN_DIR_STYLE_EX}
- const
- Shel: array[ 0..3 ] of Char = 'SHBr';
- {$ENDIF}
- var Self_ : POpenDirDialog;
- {$IFDEF NEW_OPEN_DIR_STYLE_EX}
- WList: HWnd;
- ClassBuf: array[ 0..127 ] of KOLChar;
- {$ENDIF}
- begin
- Self_ := Pointer( lpData );
- Self_.FDialogWnd := Wnd;
- if Msg = BFFM_INITIALIZED then
- begin
- if assigned( Self_.FCenterProc ) then
- Self_.FCenterProc( Wnd );
- if Self_.FInitialPath <> '' then
- begin
- {$IFDEF NEW_OPEN_DIR_STYLE_EX}
- WList := GetWindow( Wnd, GW_CHILD );
- while WList <> 0 do
- begin
- WList := GetWindow( WList, GW_HWNDNEXT );
- GetClassName( WList, @ ClassBuf[ 0 ], Sizeof( ClassBuf ) );
- if PDWord( @ ClassBuf[ 0 ] )^ = DWORD( Shel ) then
- begin
- PostMessage( Wnd, WM_NEXTDLGCTL, WList, 1 );
- break;
- end;
- end;
- PostMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PChar(
- ExtractFilePath( Self_.FInitialPath ) ) ) );
- PostMessage( WND, WM_KEYDOWN, VK_ADD, 0 );
- PostMessage( WND, WM_KEYUP, VK_ADD, 0 );
- PostMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
- {$ELSE}
- SendMessage( Wnd, BFFM_SETSELECTION, 1, Integer( PKOLChar( Self_.FInitialPath ) ) );
- {$ENDIF}
- SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
- end;
- end
- else
- if Msg = BFFM_SELCHANGED then
- begin
- if assigned( Self_.FDoSelChanged ) then
- Self_.FDoSelChanged( Wnd, Msg, lParam, lpData )
- else
- SendMessage( Wnd, BFFM_ENABLEOK, 0, 1 );
- end;
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
- //[END OpenDirCallBack]
-
- //[PROCEDURE OpenDirDlgCenter]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure OpenDirDlgCenter( Wnd: HWnd );
- var R: TRect;
- W, H: Integer;
- begin
- GetWindowRect( Wnd, R );
- W := R.Right - R.Left;
- H := R.Bottom - R.Top;
- R.Left := (GetSystemMetrics( SM_CXSCREEN ) - W) div 2;
- R.Top := (GetSystemMetrics( SM_CYSCREEN ) - H) div 2;
- MoveWindow( Wnd, R.Left, R.Top, W, H, True );
- end;
- {$ENDIF ASM_VERSION}
- //[END OpenDirDlgCenter]
-
- //[procedure TOpenDirDialog.SetCenterOnScreen]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TOpenDirDialog.SetCenterOnScreen(const Value: Boolean);
- var P: procedure( Wnd: HWnd );
- begin
- FCenterOnScreen := Value;
- P := nil;
- if Value then
- P := @OpenDirDlgCenter;
- FCenterProc := P;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TOpenDirDialog.SetInitialPath]
- procedure TOpenDirDialog.SetInitialPath(const Value: KOLString);
- begin
- FCallBack := @OpenDirCallBack;
- FInitialPath := ExcludeTrailingPathDelimiter( Value );
- if (FInitialPath <> '') and
- (FInitialPath[ Length( FInitialPath ) ] = ':') then
- FInitialPath := IncludeTrailingPathDelimiter( Value );
- end;
-
- //[procedure TOpenDirDialog.SetOnSelChanged]
- procedure TOpenDirDialog.SetOnSelChanged(const Value: TOnODSelChange);
- begin
- FOnSelChanged := Value;
- FCallBack := @OpenDirCallBack;
- FDoSelChanged := @OpenDirSelChangeCallBack;
- end;
- {$endif wince}
-
- type
- PByteArray =^TByteArray;
- TByteArray = array[Word]of Byte;
-
- //[function CreateMappedBitmapEx]
- function CreateMappedBitmapEx(Instance: THandle; BmpRsrcName: PKOLChar; Flags:
- Cardinal; ColorMap: PColorMap; NumMaps: Integer): HBitmap;
- var tmcl: Cardinal;
- {$ifndef wince}
- bi: TBITMAPINFO;
- DC: Cardinal;
- {$endif}
- Bits: PByteArray;
- i, j, k, CO, bps: Integer;
- tm: array [1..4] of byte absolute tmcl;
- bm: Windows.TBITMAP;
- CM: PColorMap;
- {$ifdef wince}
- tbmp, tbmp2: PBitmap;
- {$else}
- DW: HWnd;
- {$endif wince}
- begin
- Result := LoadBitmap( Instance, BmpRsrcName );
- if Result = 0 then
- begin
- {$IFDEF DEBUG}
- ShowMessage( 'Can not load bitmap ' + BmpRsrcName + ', error ' +
- Int2Str( GetLastError ) + ': ' + SysErrorMessage( GetLastError ) );
- {$ENDIF}
- Exit;
- end;
- FillChar( bm, SizeOf(bm), #0 );
- GetObject( Result, SizeOf( bm ), @bm );
- {$ifdef wince}
- tbmp:=NewDIBBitmap(bm.bmWidth, bm.bmHeight, pf24bit);
- tbmp2:=NewBitmap(0, 0);
- tbmp2.Handle:=Result;
- tbmp2.Draw(tbmp.Canvas.Handle, 0, 0);
- tbmp.RemoveCanvas;
- Bits:=tbmp.DIBBits;
- bps := CalcScanLineSize( @tbmp.DibHeader.bmiHeader );
- CM:=ColorMap;
- for k := 1 to NumMaps do begin
- tbmp2.Pixels[0, 0]:=Color2RGB(CM.{$ifdef wince}from{$else}cFrom{$endif});
- CM.{$ifdef wince}from{$else}cFrom{$endif}:=tbmp2.Pixels[0, 0];
- CM.{$ifdef wince}_to{$else}cTo{$endif}:=Color2RGB(CM.{$ifdef wince}_to{$else}cTo{$endif});
- Inc(CM);
- end;
- tbmp2.Free;
- {$else}
- FillChar( bi, SizeOf( bi ), #0 );
- bi.bmiHeader.biSize := SizeOf( bi.bmiHeader );
- bi.bmiHeader.biWidth := bm.bmWidth;
- bi.bmiHeader.biHeight := -bm.bmHeight;
- bi.bmiHeader.biPlanes := 1;
- bi.bmiHeader.biBitCount := 24;
- // BitCout - always 24 for easy algorythm
- bi.bmiHeader.biCompression:=BI_RGB;
- bps := CalcScanLineSize( @bi.bmiHeader );
- GetMem( Bits, bps * bm.bmHeight );
- DW := GetDesktopWindow;
- DC := GetDC(DW);
- GetDIBits( DC, Result, 0, bm.bmHeight, @Bits[0], bi, DIB_RGB_COLORS );
- DeleteObject( Result );
- {$endif wince}
-
- for i := 0 to bm.bmHeight - 1 do begin
- for j := 0 to bm.bmWidth - 1 do begin
- CO := bps * i + 3 * j;
- for k := 0 to NumMaps - 1 do begin
- CM := Pointer( cardinal( ColorMap ) + SizeOf( TColorMap ) * cardinal(k) );
- if RGB( Bits[CO+2], Bits[CO+1], Bits[CO] ) = CM.{$ifdef wince}from{$else}cFrom{$endif} then
- begin
- tmcl := CM.{$ifdef wince}_to{$else}cTo{$endif};
- tm[4]:=tm[1];
- tm[1]:=tm[3];
- tm[3]:=tm[4];
- Move( tmcl, Bits[CO], 3);
- end;
- end;
- end;
- end;
- {$ifdef wince}
- Result:=tbmp.ReleaseHandle;
- tbmp.Free;
- {$else}
- Result := CreateDIBitmap( DC, bi.bmiHeader, CBM_INIT, @Bits[0], bi,
- DIB_RGB_COLORS );
- ReleaseDC( DW, DC );
- FreeMem( Bits );
- {$endif wince}
- end;
-
- {$ifdef wince}
- function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
- Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- Result:=CreateMappedBitmapEx(Instance, PKOLChar(Bitmap), Flags, ColorMap, NumMaps);
- end;
- {$else}
- //[API CreateMappedBitmap]
- function CreateMappedBitmap(Instance: THandle; Bitmap: Integer;
- Flags: UINT; ColorMap: PColorMap; NumMaps: Integer): HBitmap; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external cctrl name 'CreateMappedBitmap';
- {$endif wince}
-
- //*
- //[function LoadMappedBitmap]
- function LoadMappedBitmap( hInst: THandle; BmpResID: Integer; const Map: array of TColor )
- : HBitmap;
- var Map2Pass: Pointer;
- begin
- Map2Pass := nil;
- if High( Map ) > 0 then
- Map2Pass := PColorMap( @Map[ 0 ] );
- Result := CreateMappedBitmap( hInst, BmpResID, 0, Map2Pass, (High( Map ) + 1) div 2 );
- end;
-
- //[function LoadMappedBitmapEx]
- function LoadMappedBitmapEx( MasterObj: PObj; hInst: THandle; BmpResName: PKOLChar; const Map: array of TColor )
- : HBitmap;
- var Map2Pass: Pointer;
- begin
- Map2Pass := nil;
- if High( Map ) > 0 then
- Map2Pass := PColorMap( @Map[ 0 ] );
- Result := CreateMappedBitmapEx( hInst, BmpResName, 0, Map2Pass, (High( Map ) + 1) div 2 );
- if MasterObj <> nil then
- MasterObj.Add2AutoFreeEx( TObjectMethod( MakeMethod( Pointer( Result ), @ FreeBmp ) ) );
- end;
-
- { -- Toolbar -- }
-
- {$IFDEF ASM_noVERSION} // width
- //[procedure TControl.TBAddBitmap]
- procedure TControl.TBAddBitmap(Bitmap: HBitmap);
- const szBI = sizeof(TBitmapInfo);
- asm
- TEST EDX, EDX
- JZ @@exit
- JGE @@1
- CMP EDX, -6
- JL @@1
-
- NEG EDX
- DEC EDX
- PUSH EDX
- PUSH -1
- XOR EDX, EDX
- JMP @@2
-
- @@1: PUSH EDX // AB.hInst = Bitmap
- PUSH 0 // AB.nID = 0
-
- PUSH EAX // > @Self
- ADD ESP, -szBI
- PUSH ESP
- PUSH szBI
- PUSH EDX
- CALL GetObject
- TEST EAX, EAX
- JG @@11
-
- ADD ESP, szBI
- JMP @@exit
-
- @@11: MOV EAX, [ESP].TBitmapInfo.bmiHeader.biWidth
- MOV ECX, [ESP].TBitmapInfo.bmiHeader.biHeight
- TEST ECX, ECX
- JGE @@12
- NEG ECX
- @@12: ADD ESP, szBI
- CDQ // EDX = 0
- DIV ECX // EAX = N
- XCHG EAX, [ESP] // > N
- PUSH EAX // > @Self
-
- MOV EDX, ECX
- SHL EDX, 16
- OR ECX, EDX
- CDQ
- PUSH EDX
- PUSH EDX
- PUSH TB_AUTOSIZE
- PUSH EAX
-
- PUSH ECX
- PUSH EDX
- PUSH TB_SETBITMAPSIZE
- PUSH EAX
- CALL Perform
- CALL Perform
- POP EAX
- POP EDX
-
- @@2: PUSH ESP
- PUSH EDX
- PUSH TB_ADDBITMAP
- PUSH EAX
- CALL Perform
- POP ECX
- POP ECX
- @@exit:
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.TBAddBitmap(Bitmap: HBitmap);
- //const NstdBitmaps: array[ 0..5 ] of DWORD = ( 15, 15, 0, 0, 13, 13 );
- var BI: TBitmapInfo;
- AB: TTBAddBitmap;
- N, W: Integer;
- begin
- if Bitmap = 0 then Exit;
- if (Integer( Bitmap ) >= -10) and (Integer( Bitmap ) <= -1) then
- begin
- AB.hInst := THandle(-1);
- AB.nID := -Integer(Bitmap) - 1;
- N := 0; //NstdBitmaps[ AB.nID ]; // (this value is ignored)
- end
- else
- if GetObject( Bitmap, sizeof( TBitmapInfo ), @BI ) > 0 then
- begin
- AB.hInst := 0;
- AB.nID := Bitmap;
- W := fTBBtnImgWidth;
- if W = 0 then
- W := Abs( BI.bmiHeader.biHeight );
- N := BI.bmiHeader.biWidth div W;
- Perform( TB_SETBITMAPSIZE, 0, MAKELONG( W, Abs(BI.bmiHeader.biHeight )) );
- Perform( TB_AUTOSIZE, 0, 0 );
- end
- else Exit;
- Perform( TB_ADDBITMAP, N, Integer( @AB ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TBAddInsButtons]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBAddInsButtons(Idx: Integer; const Buttons: array of PKOLChar;
- const BtnImgIdxArray: array of Integer): Integer;
-
- function AddInsButtons: Integer;
- type TTBBtnArray = array[ 0..100000 ] of TTBButton;
- PTBBtnArray = ^TTBBtnArray;
- var AB: PTBBtnArray;
- I, N, nBmp: Integer;
- PAB: PTBButton;
- Str: PKOLChar;
- begin
- Result := -1;
- AB := nil;
- if High( Buttons ) >= 0 then
- GetMem( AB, Sizeof( TTBButton ) * (High(Buttons) + 1) );
- N := 0;
- PAB := @AB[ 0 ];
- nBmp := -2;
- if High(BtnImgIdxArray) >= 0 then
- nBmp := BtnImgIdxArray[ 0 ] - 1;
- for I:= 0 to High( Buttons ) do
- begin
- if Buttons[ I ] = nil then break;
- if {$IFDEF UNICODE_CTRLS} WStrComp {$ELSE} StrComp {$ENDIF}
- ( Buttons[ I ], {$IFDEF F_P}''+{$ENDIF} '-' ) = 0 then
- begin
- PAB.iBitmap := -1;
- //PAB.idCommand := 0;
- PAB.fsState := 0;
- PAB.fsStyle := TBSTYLE_SEP;
- PAB.iString := -1;
- end
- else
- begin
- Str := Buttons[ I ];
- Inc( nBmp );
- PAB.iBitmap := nBmp;
- if nBmp < 0 then
- Dec( nBmp );
- if High( BtnImgIdxArray ) >= N then
- PAB.iBitmap := BtnImgIdxArray[ N ];
- PAB.fsState := TBSTATE_ENABLED;
- PAB.fsStyle := TBSTYLE_BUTTON or TBSTYLE_AUTOSIZE;
- if Str^ = '^' then
- begin
- PAB.fsStyle := TBSTYLE_DROPDOWN or TBSTYLE_AUTOSIZE;
- Inc( Str );
- end;
- if CharIn( Str^, [ '-', '+' ] ) then
- begin
- PAB.fsStyle := PAB.fsStyle or TBSTYLE_CHECK;
- if Str^ = '+' then
- PAB.fsState := PAB.fsState or TBSTATE_CHECKED;
- Inc( Str );
- if Str^ = '!' then
- begin
- PAB.fsStyle := PAB.fsStyle or TBSTYLE_GROUP;
- Inc( Str );
- end;
- end;
- {$IFDEF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
- if Str^ = '.' then
- begin
- PAB.fsStyle := PAB.fsStyle and not TBSTYLE_AUTOSIZE;
- inc( Str );
- end;
- {$ENDIF TOOLBAR_DOT_NOAUTOSIZE_BUTTON}
- if (Str = KOLString( {$IFDEF F_P}''+{$ENDIF} KOLChar( ' ' ) )) or (Str^ = #0) then
- PAB.iString := -1
- //Perform( TB_ADDSTRING, 0, Integer( PChar( '' + #0 ) ) )
- // an experiment: is it possible to remove space right to image
- // without setting tboTextBottom option (non compatible with FixFlatXP)
- // answer: seems not possible.
- else
- PAB.iString :=
- Perform( TB_ADDSTRING, 0, Integer( PKOLChar( KOLString( '' + Str + #0 ) ) ) );
- end;
-
- PAB.idCommand := ToolbarsIDcmd;
- if Result < 0 then Result := PAB.idCommand;
- Inc( ToolbarsIDcmd );
-
- PAB.dwData := Integer( @Self );
- Inc( N );
- Inc( PAB );
- end;
- if N > 0 then
- begin
- if Idx < 0 then
- Perform( TB_ADDBUTTONS, N, Integer( @AB[ 0 ] ) )
- else
- Perform( TB_INSERTBUTTON, Idx, Integer( @AB[ 0 ] ) );
- end;
- if AB <> nil then
- FreeMem( AB );
- end;
- begin
- if High( Buttons ) < 0 then
- Result := -1
- else
- Result := AddInsButtons;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TBAddButtons]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBAddButtons(const Buttons: array of PKOLChar;
- const BtnImgIdxArray: array of Integer): Integer;
- begin
- Result := TBAddInsButtons( -1, Buttons, BtnImgIdxArray );
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TControl.TBInsertButtons]
- function TControl.TBInsertButtons(BeforeIdx: Integer;
- Buttons: array of PKOLChar; BtnImgIdxArray: array of Integer): Integer;
- var I, J, K: Integer;
- begin
- J := -1;
- Result := -1;
- for I := 0 to High( Buttons ) do
- begin
- if I <= High( BtnImgIdxArray ) then
- J := BtnImgIdxArray[ I ]
- else
- if J >= 0 then Inc( J );
- K := TBAddInsButtons( BeforeIdx, [ Buttons[ I ], '' ], [ J ] );
- if Result < 0 then Result := K;
- end;
- end;
-
- //[function GetTBBtnGoodID]
- function GetTBBtnGoodID( Toolbar: PControl; BtnIDorIdx: Integer ): Integer;
- // change by Alexander Pravdin (to fix toolbar with separator first):
- //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- var Btn1st, i: Integer; btn: TTBButton;
- begin
- Result := BtnIDorIdx;
- Btn1st := 0;
- for i := 0 to Toolbar.TBButtonCount - 1 do begin
- Toolbar.Perform( TB_GETBUTTON, i, Integer( @btn ) );
- if btn.fsStyle <> TBSTYLE_SEP then begin
- Btn1st := i;
- Break;
- end;
- end;
- if Result < Toolbar.TBIndex2Item( Btn1st ) then
- Result := Toolbar.TBIndex2Item( Result );
- end;
-
- type
- TTBButtonEvent = {$ifndef wince}packed{$endif} Record
- BtnID: DWORD;
- Event: TOnToolbarButtonClick;
- end;
- PTBButtonEvent = ^TTBButtonEvent;
-
- //[procedure TControl.TBFreeTBevents]
- procedure TControl.TBFreeTBevents;
- begin
- //if fTBevents <> nil then
- begin
- fTBevents.Release;
- //fTBevents := nil;
- end;
- end;
-
- //[function WndProcToolbarButtonsClicks]
- function WndProcToolbarButtonsClicks( TB: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- Event: PTBButtonEvent;
- begin
- Result := FALSE;
- if Msg.message = CM_COMMAND then
- begin
- for I := TB.fTBevents.fCount-1 downto 0 do
- begin
- Event := TB.fTBevents.fItems[ I ];
- if Integer( Event.BtnID ) = LoWord( Msg.wParam ) then
- begin
- if Assigned( Event.Event ) then
- begin
- TB.RefInc;
- Rslt := DefWindowProc( Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam );
- Event.Event( TB, Event.BtnID );
- TB.RefDec;
- Result := TRUE;
- Exit;
- end;
- break;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.TBAssignEvents]
- procedure TControl.TBAssignEvents(BtnID: Integer;
- Events: array of TOnToolbarButtonClick);
- var I: Integer;
- EventRec: PTBButtonEvent;
- begin
- if fTBevents = nil then
- begin
- fTBevents := NewList;
- Add2AutoFreeEx( TBFreeTBevents );
- AttachProc( WndProcToolbarButtonsClicks );
- end;
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- for I := 0 to High( Events ) do
- begin
- GetMem( EventRec, Sizeof( TTBButtonEvent ) );
- fTBevents.Add( EventRec );
- EventRec.Event := Events[ I ];
- EventRec.BtnID := BtnID;
- Inc( BtnID );
- end;
- end;
-
- //[procedure TControl.TBResetImgIdx]
- procedure TControl.TBResetImgIdx( BtnID, BtnCount: Integer );
- begin
- while BtnCount > 0 do
- begin
- TBButtonImage[ BtnID ] := -2;
- Inc( BtnID );
- Dec( BtnCount );
- end;
- end;
-
- //*
- //[function TControl.TBGetButtonVisible]
- function TControl.TBGetButtonVisible(BtnID: Integer): Boolean;
- begin
- Result := Perform( TB_ISBUTTONHIDDEN, GetTBBtnGoodID( @ Self, BtnID ), 0 ) = 0;
- end;
-
- //*
- //[function TControl.TBItem2Index]
- function TControl.TBItem2Index(BtnID: Integer): Integer;
- begin
- Result := Perform( TB_COMMANDTOINDEX, BtnID, 0 );
- end;
-
- //*
- //[procedure TControl.TBSetButtonVisible]
- procedure TControl.TBSetButtonVisible(BtnID: Integer;
- const Value: Boolean);
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Perform( TB_HIDEBUTTON, BtnID, Integer( not Value ) );
- end;
-
- //[function TControl.TBGetBtnStt]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBGetBtnStt(BtnID: Integer; const Index: Integer): Boolean;
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Result := Perform( Index + 8, BtnID, 0 ) <> 0;
- end;
- {$ENDIF ASM_VERSION}
-
- //+
- //[procedure TControl.TBSetBtnStt]
- procedure TControl.TBSetBtnStt(BtnID: Integer; const Index: Integer; const Value: Boolean);
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Perform( Index, BtnID, Integer( Value ) );
- end;
-
- //[function TControl.TBIndex2Item]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBIndex2Item(Idx: Integer): Integer;
- var ButtonInfo: TTBButton;
- begin
- Result := -1;
- if Perform( TB_GETBUTTON, Idx, Integer( @ButtonInfo ) ) <> 0 then
- Result := ButtonInfo.idCommand;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.TBConvertIdxArray2ID]
- procedure TControl.TBConvertIdxArray2ID(const IdxVars: array of PDWORD);
- var i: Integer;
- begin
- for i := 0 to High( IdxVars ) do
- IdxVars[ i ]^ := TBIndex2Item( IdxVars[ I ]^ );
- end;
-
- //[function TControl.TBGetButtonText]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBGetButtonText( BtnID: Integer ): KOLString;
- var Buffer: array[ 0..1023 ] of KOLChar;
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- if Perform( TB_GETBUTTONTEXT, BtnID, Integer( @Buffer[ 0 ] ) ) > 0 then
- Result := Buffer
- else
- Result := '';
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[function TControl.TBGetButtonRect]
- function TControl.TBGetButtonRect(BtnID: Integer): TRect;
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Perform( TB_GETITEMRECT, TBItem2Index( BtnID ), Integer( @Result ) );
- end;
-
- function ToolbarButtonRect( Toolbar: PControl; BtnID: Integer ): TRect;
- begin
- Result := Toolbar.TBGetButtonRect(BtnID);
- end;
-
- //*
- //[function TControl.TBGetRows]
- function TControl.TBGetRows: Integer;
- begin
- Result := 1;
- UpdateWndStyles;
- if (TBSTYLE_WRAPABLE and fStyle) <> 0 then
- Result := Perform( TB_GETROWS, 0, 0 );
- end;
-
- //*
- //[procedure TControl.TBSetRows]
- procedure TControl.TBSetRows(const Value: Integer);
- begin
- Perform( TB_SETROWS, Value, 0 );
- end;
-
- //[function TControl.TBMoveBtn]
- function TControl.TBMoveBtn(FromIdx, ToIdx: Integer): Boolean;
- var btn: TTBButton;
- begin
- Perform(TB_GETBUTTON,FromIdx,integer(@btn));
- Result := Perform(TB_DELETEBUTTON,FromIdx,0) <> 0;
- if Result then
- Perform(TB_INSERTBUTTON,ToIdx,integer(@btn));
- end;
-
- //[procedure TControl.TBSetTooltips]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.TBSetTooltips(BtnID1st: Integer;
- const Tooltips: array of PKOLChar);
- var I, J: Integer;
- begin
- if not assigned( fTBttTxt ) then
- begin
- {$ifndef wince}
- fTBttCmd := NewList;
- {$endif wince}
- fTBttTxt := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
- {$IFDEF USE_AUTOFREE4CONTROLS}
- {$ifndef wince}
- Add2AutoFree( fTBttCmd );
- {$endif wince}
- Add2AutoFree( fTBttTxt );
- {$ENDIF}
- end;
- {$ifdef wince}
- j:=TBItem2Index(BtnID1st);
- BtnID1st:=-1;
- for i:=0 to j do
- if not TBButtonSeparator(i) then
- Inc(BtnID1st);
- for i:=fTBttTxt.Count - 1 to BtnID1st - 1 do
- fTBttTxt.Add('');
- for I:=0 to High( Tooltips ) do begin
- if BtnID1st < fTBttTxt.Count then
- fTBttTxt.Items[BtnID1st]:=Tooltips[ I ]
- else
- fTBttTxt.Add( Tooltips[ I ] );
- Inc(BtnID1st);
- end;
- Perform(TB_SETTOOLTIPS, fTBttTxt.Count, LPARAM(fTBttTxt.fList.fItems));
- {$else}
- for I:= 0 to High( Tooltips ) do
- begin
- J := fTBttCmd.IndexOf( Pointer( BtnID1st ) );
- if J < 0 then
- begin
- fTBttCmd.Add( Pointer( BtnID1st ) );
- fTBttTxt.Add( Tooltips[ I ] );
- end
- else
- fTBttTxt.Items[ J ] := Tooltips[ I ];
- Inc( BtnID1st );
- end;
- {$endif wince}
- end;
- {$ENDIF ASM_VERSION}
-
- procedure ToolbarSetTooltips( Toolbar: PControl; BtnID1st: Integer;
- const Tooltips: array of PKOLChar );
- begin
- Toolbar.TBSetTooltips( BtnID1st, Tooltips );
- end;
-
- function ToolbarButtonEnabled( Toolbar: PControl; BtnID: Integer ): Boolean;
- begin
- Result := Toolbar.TBButtonEnabled[ BtnID ];
- end;
-
- procedure EnableToolbarButton( Toolbar: PControl; BtnID: Integer; Enable: Boolean );
- begin
- Toolbar.TBButtonEnabled[ BtnID ] := Enable;
- end;
-
- function ToolbarButtonVisible( Toolbar: PControl; BtnID: Integer ): Boolean;
- begin
- Result := Toolbar.TBButtonVisible[ BtnID ];
- end;
-
- procedure ShowHideToolbarButton( Toolbar: PControl; BtnID: Integer; Show: Boolean );
- begin
- Toolbar.TBButtonVisible[ BtnID ] := Show;
- end;
-
- function ToolbarButtonChecked( Toolbar: PControl; BtnID: Integer): Boolean;
- begin
- Result := Toolbar.TBButtonChecked[ BtnID ];
- end;
-
- procedure ToolbarButtonSetChecked( Toolbar: PControl; BtnID: Integer; Checked: Boolean );
- begin
- Toolbar.TBButtonChecked[ BtnID ] := Checked;
- end;
-
- //[function TControl.TBButtonAtPos]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBButtonAtPos(X, Y: Integer): Integer;
- var I: Integer;
- begin
- I := TBBtnIdxAtPos( X, Y );
- if I >= 0 then
- I := TBIndex2Item( I );
- Result := I;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TBBtnIdxAtPos]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBBtnIdxAtPos(X, Y: Integer): Integer;
- var I: Integer;
- R: TRect;
- P: TPoint;
- begin
- P := MakePoint( X, Y );
- for I := TBButtonCount - 1 downto 0 do
- begin
- Perform( TB_GETITEMRECT, I, Integer( @R ) );
- if PointInRect( P, R ) then
- begin
- Result := I;
- Exit;
- end;
- end;
- Result := -1;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TBButtonSeparator]
- function TControl.TBButtonSeparator(BtnID: Integer): Boolean;
- var B: TTBButton;
- begin
- Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID )), Integer( @B ) ) ;
- Result := B.fsStyle = TBSTYLE_SEP;
- end;
-
- //*
- //[procedure TControl.TBDeleteButton]
- procedure TControl.TBDeleteButton(BtnID: Integer);
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Perform( TB_DELETEBUTTON, TBItem2Index( BtnID ), 0 );
- end;
-
- //*
- //[procedure TControl.TBDeleteBtnByIdx]
- procedure TControl.TBDeleteBtnByIdx(Idx: Integer);
- begin
- Perform( TB_DELETEBUTTON, Idx, 0 );
- end;
-
- //*
- //[procedure TControl.Clear]
- procedure TControl.Clear;
- begin
- fCommandActions.aClear( @Self );
- end;
-
- {$IFDEF ASM_noVERSION}
- //[function TControl.TBGetBtnImgIdx]
- function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;
- const szTBButton = sizeof( TTBButton );
- asm
- ADD ESP, -szTBButton
- PUSH ESP
- PUSH EAX
- CALL TBItem2Index
- POP EDX
- PUSH EAX
- PUSH TB_GETBUTTON
- PUSH EDX
- CALL Perform
- POP EAX
- ADD ESP, szTBButton-4
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBGetBtnImgIdx(BtnID: Integer): Integer;
- var B: TTBButton;
- begin
- Perform( TB_GETBUTTON, TBItem2Index( GetTBBtnGoodID( @Self, BtnID ) ), Integer( @B ) );
- Result := B.iBitmap;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[procedure TControl.TBSetBtnImgIdx]
- procedure TControl.TBSetBtnImgIdx(BtnID: Integer; const Value: Integer);
- begin
- Perform( TB_CHANGEBITMAP, GetTBBtnGoodID( @Self, BtnID ), Value );
- end;
-
- //[procedure TControl.TBSetButtonText]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.TBSetButtonText(BtnID: Integer; const Value: KOLString);
- var BI: TTBButtonInfo;
- begin
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- BI.cbSize := Sizeof( BI );
- BI.dwMask := TBIF_TEXT;
- BI.pszText := PKOLChar( Value );
- Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TControl.TBGetBtnWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.TBGetBtnWidth(BtnID: Integer): Integer;
- var R: TRect;
- begin
- R := TBButtonRect[ BtnID ];
- Result := R.Right - R.Left;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.TBSetBtnWidth]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.TBSetBtnWidth(BtnID: Integer; const Value: Integer);
- var BI: TTBButtonInfo;
- begin
- BI.cbSize := Sizeof( BI );
- BI.dwMask := TBIF_SIZE or TBIF_STYLE;
- BtnID := GetTBBtnGoodID( @Self, BtnID );
- Perform( TB_GETBUTTONINFO, BtnID, Integer( @BI ) );
- BI.cx := Value;
- BI.fsStyle := BI.fsStyle and not TBSTYLE_AUTOSIZE;
- Perform( TB_SETBUTTONINFO, BtnID, Integer( @BI ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.TBSetBtMinMaxWidth]
- procedure TControl.TBSetBtMinMaxWidth(const Idx: Integer; const Value: Integer);
- begin
- case Idx of
- 0: FTBBtMinWidth := Value;
- 1: FTBBtMaxWidth := Value;
- end;
- Perform( TB_SETBUTTONWIDTH, 0, FTBBtMaxWidth or (FTBBtMinWidth shl 16) );
- end;
-
- {$IFDEF F_P}
- //[function TControl.TBGetBtMinMaxWidth]
- function TControl.TBGetBtMinMaxWidth(const Idx: Integer): Integer;
- begin
- CASE Idx OF
- 0: Result := FTBBtMinWidth;
- 1: Result := FTBBtMaxWidth;
- END;
- end;
- {$ENDIF F_P}
-
- {$ifndef wince}
- function WndProcTBCustomDraw( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var CD: PNMTBCustomDraw;
- Br: HBrush;
- begin
- Result := FALSE;
- if Msg.message = WM_NOTIFY then
- begin
- CD := Pointer( Msg.lParam );
- if longint(CD.nmcd.hdr.code) = NM_CUSTOMDRAW then
- begin
- if Assigned( Sender.OnTBCustomDraw ) then
- Rslt := Sender.OnTBCustomDraw( Sender, CD^ )
- else
- begin
- if Assigned( Sender.fBrush ) then
- Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Sender.fBrush.Handle )
- else
- begin
- Br := CreateSolidBrush( Color2RGB( Sender.Color ) );
- Windows.FillRect( CD.nmcd.hdc, Sender.ClientRect, Br );
- DeleteObject( Br );
- end;
- Rslt := CDRF_SKIPDEFAULT;
- end;
- end;
- end;
- end;
-
- procedure TControl.SetOnTBCustomDraw( const Value: TOnTBCustomDraw );
- begin
- fOnTBCustomDraw := Value;
- AttachProc( WndProcTBCustomDraw );
- end;
- {$endif wince}
- //[procedure TControl.SetDroppedDown]
- procedure TControl.SetDroppedDown(const Value: Boolean);
- begin
- //fDropped := Value;
- Perform( CB_SHOWDROPDOWN, Integer( Value ), 0 );
- end;
-
- //[procedure TControl.AddDirList]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.AddDirList(const Filemask: KOLString; Attrs: DWORD);
- begin
- if fCommandActions.aDir <> 0 then
- Perform( fCommandActions.aDir, Attrs, Integer( PKOLChar( Filemask ) ) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION WndProcShowModal]
- {$IFDEF ASM_noVERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcShowModal( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- //var Accept: Boolean; // {Alexander Pravdin, AP}
- begin
- if Msg.message = WM_CLOSE then
- begin
- if Self_.ModalResult = 0 then { (Sergey Shishmintzev) }
- Self_.ModalResult := -1;
- Rslt := 0;
- Result := True; // Do not process !
- end
- else
- {$ifdef wince}
- if Msg.message = WM_COMMAND then begin
- if (HIWORD(Msg.wParam) = 4096) or (HWND(Msg.lParam) = Msg.hwnd) then begin
- if Self_.fDefaultBtnCtl <> nil then
- if Self_.fDefaultBtnCtl.Enabled then
- Self_.fDefaultBtnCtl.Click
- else
- Self_.ModalResult:=IDCANCEL
- else
- Self_.ModalResult:=IDOK;
- Rslt := 0;
- Result := True;
- end
- else begin
- Rslt := 1;
- Result := False;
- end;
- end
- else
- {$endif wince}
- Result := False;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcShowModal]
-
- //[function WndProcFixModal]
- // by TR"]F
- function WndProcFixModal( Self_: PControl; var Msg: TMsg; var Rslt:
- Integer ): Boolean;
- const HTERROR = $FFFE;
- LBtnDown = $201;
- LBtnUp = $202;
- RBtnDown = $204;
- RBtnUp = $205;
- WeelDown = $207;
- WeelUp = $208;
- {$IFDEF MODAL_ACTIVATE_FIX}
- var i: Integer;
- C: PControl;
- {$ENDIF MODAL_ACTIVATE_FIX}
- begin
- Result := false;
- if (Msg.message = WM_SETCURSOR) then
- if (LoWord(Msg.lParam) = HTERROR) then
- if (HiWord(Msg.lParam) >= LBtnDown) and
- (HiWord(Msg.lParam) <= RBtnUp) then
- begin
- if Applet.fModalForm <> nil then
- SetForegroundWindow(Applet.fModalForm.Handle);
- Rslt := 1;
- Result := TRUE;
- end;
-
- {$IFDEF MODAL_ACTIVATE_FIX}
- if (Msg.message = WM_ACTIVATEAPP) then
- begin
- if not Applet.fActivating then
- begin
- Applet.fActivating := TRUE;
- if Msg.wParam <> 0 then
- begin
- for i := Applet.ChildCount-1 downto 0 do
- begin
- C := Applet.Children[ i ];
- if C.Visible and not C.Enabled then
- SetForegroundWindow( C.Handle );
- end;
- SetForegroundWindow( Applet.fModalForm.Handle );
- end;
- Applet.fActivating := FALSE;
- end;
- end;
- {$ENDIF MODAL_ACTIVATE_FIX}
- end;
- //[END WndProcFixModal]
-
- {$IFDEF ASM_noVERSION}
- //[function TControl.ShowModal]
- function TControl.ShowModal: Integer;
- asm
- MOV ECX, [EAX].fParent
- JECXZ @@show
- MOVZX ECX, [EAX].fIsControl
- JECXZ @@show_modal
- @@show:
- CALL Show
- XOR EAX, EAX
- RET
- @@show_modal:
- PUSHAD
-
- MOV EBX, EAX
- MOV EDI, [Applet]
-
- XOR EBP, EBP // CurCtl = nil
-
- MOV EAX, [EDI].fCurrentControl
- CMP [EDI].TControl.FIsApplet, 0
- {$IFDEF USE_CMOV}
- CMOVZ EAX, EDI
- {$ELSE}
- JNZ @@curctrl_save
- MOV EAX, EDI
- @@curctrl_save:
- {$ENDIF}
-
- PUSH EAX
-
- MOV EDX, offset[WndProcShowModal]
- PUSH EDX
-
- MOV EAX, EBX
- CALL TControl.AttachProc
- XOR EDX, EDX
- MOV [EBX].fModalResult, EDX
-
- CALL NewList
- XCHG EAX, EBP
-
- XOR ECX, ECX
- INC ECX
- MOV ESI, EDI
-
- CMP [EDI].TControl.FIsApplet, 0
- JZ @@isapplet
-
- MOV EBP, [EDI].fCurrentControl // CurCtl = Applet.fCurrentControl
-
- MOV ESI, [EDI].fChildren
- MOV ECX, [ESI].TList.fCount
- MOV ESI, [ESI].TList.fItems
-
- @@1loo: LODSD
-
- @@isapplet:
-
- PUSH ECX
- CMP EAX, EBX
- JE @@1nx
- PUSH EAX
- CALL GetEnabled
- TEST AL, AL
- POP EAX
- JZ @@1nx
- PUSH EAX
- MOV DL, 0
- CALL SetEnabled
- POP EDX
- MOV EAX, EBP
- CALL TList.Add
- @@1nx: POP ECX
- LOOP @@1loo
-
- INC [EBX].fModal
- MOV EAX, [Applet]
- MOV [EAX].fModalForm, EBX
-
- MOV EAX, EBX
- CALL Show
-
- @@msgloo:
- MOVZX ECX, [AppletTerminated]
- OR ECX, [EBX].fModalResult
- JNZ @@e_msgloo
- CALL WaitMessage
- MOV EAX, EDI
- CALL ProcessMessages
- {$IFDEF USE_OnIdle}
- MOV EAX, EBX
- CALL [ProcessIdle]
- {$ENDIF}
- JMP @@msgloo
-
- @@e_msgloo:
- POP EDX
- MOV EAX, EBX
- CALL TControl.DetachProc
-
- DEC [EBX].fModal
- MOV EAX, [Applet]
- XOR ECX, ECX
- MOV [EAX].fModalForm, ECX
-
- MOV ECX, [EBP].TList.fCount
- JECXZ @@2end
- MOV ESI, [EBP].TList.fItems
-
- @@2loo: LODSD
- PUSH ECX
- MOV DL, 1
- CALL TControl.SetEnabled
- POP ECX
- LOOP @@2loo
-
- @@2end:
- MOV EAX, EBP
- CALL TObj.Free
-
- POP ECX
- JECXZ @@exit
- PUSH 0
- PUSH WA_ACTIVE
- PUSH WM_ACTIVATE
- PUSH [ECX].fHandle
- CALL PostMessage
-
- TEST EBP, EBP // CurCtl = nil ?
- JZ @@exit
- MOV EAX, EBP
- MOV DL, 1
- CALL TControl.SetFocused
-
- @@exit:
- POPAD
- MOV EAX, [EAX].fModalResult
- end;
- {$ELSE ASM_VERSION} //Pascal
- {$IFDEF USE_SHOWMODALPARENTED_ALWAYS}
- function TControl.ShowModal: Integer;
- begin
- Result := ShowModalParented(Applet);
- end;
- {$ELSE not USE_SHOWMODALPARENTED_ALWAYS}
- function TControl.ShowModal: Integer;
- var FL: PList;
- var CurForm: PControl;
- I: Integer;
- F: PControl;
- CurCtl: PControl; // { Alexander Pravdin }
- begin
- Result := 0;
- if (fIsControl) or (fParent = nil) then
- begin
- Show;
- Exit;
- end;
- {$ifdef wince}
- SHDoneButton(GetWindowHandle, SHDB_SHOW);
- Style:=Style and not WS_SYSMENU;
- {$endif wince}
- AttachProc( WndProcShowModal );
- CurForm := Applet.fCurrentControl;
- FL := NewList;
- CurCtl := nil; // { Alexander Pravdin }
-
- if Applet.IsApplet then
- begin
- for I := 0 to Applet.ChildCount - 1 do
- begin
- F := Applet.fChildren.Items[ I ];
- if F <> @Self then
- if F.Enabled then
- begin
- FL.Add( F );
- F.Enabled := FALSE;
- {$IFNDEF NOT_FIX_MODAL}
- Inc( F.fFixingModal );
- F.AttachProc(WndProcFixModal); {**************}
- {$ENDIF}
- end;
- end
- end
- else
- begin
- CurForm := Applet;
- if Applet.Enabled then
- begin
- FL.Add( Applet );
- CurCtl := Applet.fCurrentControl; { Alexander Pravdin }
- Applet.Enabled := FALSE;
- {$IFNDEF NOT_FIX_MODAL}
- Inc( Applet.fFixingModal );
- Applet.AttachProc(WndProcFixModal); {**************}
- {$ENDIF}
- end;
- end;
-
- Inc( fModal );
- Applet.fModalForm := @ Self;
- Enabled := TRUE;
-
- Show;
- ModalResult := 0;
- while not AppletTerminated and (ModalResult = 0) do
- begin
- Applet.WaitAndProcessMessages;
- {$IFDEF USE_OnIdle}
- ProcessIdle( @Self );
- {$ENDIF}
- end;
-
- Dec( fModal );
- Applet.fModalForm := nil;
-
- DetachProc( WndProcShowModal );
- for I := 0 to FL.Count - 1 do
- begin
- F := FL.Items[ I ];
- {$IFNDEF NOT_FIX_MODAL}
- Dec( F.fFixingModal );
- if F.fFixingModal <= 0 then
- F.DetachProc(WndProcFixModal); {**************}
- {$ENDIF}
- F.Enabled := TRUE;
- end;
- FL.Free;
-
- if CurForm <> nil then
- PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
- if CurCtl <> nil then CurCtl.SetFocused( TRUE ); { Alexander Pravdin }
-
- Result := ModalResult;
- {$ifdef wince}
- Applet.ProcessMessages;
- {$endif wince}
- end;
- {$ENDIF USE_SHOWMODALPARENTED_ALWAYS}
- {$ENDIF ASM_VERSION}
-
- //[function TControl.ShowModalParented]
- {$IFNDEF NEW_MODAL}
- function TControl.ShowModalParented( const AParent: PControl ): Integer;
- begin
- Result := 0;
- end;
- {$ELSE NEW_MODAL defined}
- function TControl.ShowModalParented( const AParent: PControl ): Integer;
- var
- FL: PList;
- OldMF, F: PControl;
- I: Integer;
- begin
- Result := 0;
- if ( AParent = nil ) then Exit;
-
- Inc( fModal );
- FL := NewList;
- OldMF := AParent.fModalForm;
- AParent.fModalForm := @Self;
-
- if AParent.fIsApplet or ( AParent.IsMainWindow and AParent.fIsForm ) then
- begin
- for I := 0 to AParent.ChildCount - 1 do
- begin
- F := AParent.fChildren.Items[ I ];
- if ( F <> @Self ) and F.fIsForm and F.fEnabled and F.fVisible then
- begin
- FL.Add( F );
- F.Enabled := FALSE;
- {$IFNDEF NOT_FIX_MODAL}
- F.AttachProc(WndProcFixModal); {**************}
- {$ENDIF}
- end;
- end;
- end;
-
- if AParent.fIsForm and AParent.Enabled then
- begin
- FL.Add( AParent );
- AParent.Enabled := FALSE;
- end;
-
- ModalResult := 0;
- Show;
- while not AppletTerminated and ( ModalResult = 0 ) do
- begin
- AParent.WaitAndProcessMessages;
- {$IFDEF USE_OnIdle}
- ProcessIdle( @Self );
- {$ENDIF}
- end;
-
- AParent.fModalForm := OldMF;
- Dec( fModal );
- for I := 0 to FL.Count - 1 do
- begin
- F := PControl( FL.Items[ I ] );
- F.Enabled := True;
- {$IFNDEF NOT_FIX_MODAL}
- F.DetachProc(WndProcFixModal); {**************}
- {$ENDIF}
- end;
- FL.Free;
- Hide;
- Result := ModalResult;
- end;
- {$ENDIF NEW_MODAL}
-
- //[function DisableWindows]
- function DisableWindows( W: hwnd; LPARAM: Integer ): Bool; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var FL: PList;
- Buf: array[ 0..127 ] of Char;
- begin
- FL := Pointer( LPARAM );
- if IsWindowEnabled( W ) and (W <> FL.Tag) then
- begin
- GetClassName( W, @ Buf[ 0 ], Sizeof( Buf ) );
- if Buf <> 'ComboLBox' then
- begin
- FL.Add( Pointer( W ) );
- EnableWindow( W, FALSE );
- end;
- end;
- Result := TRUE;
- end;
-
- //[function TControl.ShowModalEx]
- function TControl.ShowModalEx: Integer;
- {$ifdef wince}
- begin
- Result:=ShowModal;
- {$else}
- var FL: PList;
- var CurForm: PControl;
- I: Integer;
- W: HWnd;
- CurCtl: PControl; { Alexander Pravdin }
- begin
- Result := 0;
- if (fIsControl) or (fParent = nil) then
- begin
- Show;
- Exit;
- end;
- AttachProc( WndProcShowModal );
- CurForm := Applet.fCurrentControl;
- FL := NewList;
- FL.Tag := fHandle;
- // ++++ { Alexander Pravdin }
- if not Applet.fIsApplet then CurCtl := Applet.fCurrentControl
- else CurCtl := nil;
- // ----
- CreateWindow;
-
- EnumThreadWindows( GetCurrentThreadID, @ DisableWindows, Integer( FL ) );
- Enabled := TRUE;
-
- Inc( fModal );
- Applet.fModalForm := @ Self;
- Show;
- ModalResult := 0;
- while not AppletTerminated and (ModalResult = 0) do
- begin
- Applet.WaitAndProcessMessages;
- {$IFDEF USE_OnIdle}
- ProcessIdle( @Self );
- {$ENDIF}
- end;
-
- Dec( fModal );
- Applet.fModalForm := @ Self;
-
- DetachProc( WndProcShowModal );
-
- for I := 0 to FL.Count - 1 do
- begin
- W := THandle( FL.Items[ I ] );
- EnableWindow( W, TRUE );
- end;
- FL.Free;
-
- if CurForm <> nil then
- PostMessage( CurForm.Handle, WM_ACTIVATE, WA_ACTIVE, 0 );
- if CurCtl <> nil then CurCtl.SetFocused( True ); { Alexander Pravdin }
- Result := ModalResult;
- {$endif wince}
- end;
-
- //[function TControl.GetModal]
- function TControl.GetModal: Boolean;
- begin
- Result := fModal > 0;
- end;
-
- {$IFDEF USE_SETMODALRESULT}
- //[procedure TControl.SetModalResult]
- procedure TControl.SetModalResult( const Value: Integer );
- begin
- //if fModal <= 0 then Exit;
- fModalResult := Value;
- if Value <> 0 then
- PostMessage( GetWindowHandle, 0, 0, 0 );
- end;
- {$ENDIF}
-
- {$IFNDEF NEW_MENU_ACCELL}
- procedure TControl.DoDestroyAccelTable;
- begin
- if fAccelTable <> 0 then
- begin
- DestroyAcceleratorTable( fAccelTable );
- fAccelTable := 0;
- end;
- end;
- {$ENDIF}
-
- {$ENDIF WIN_GDI} //^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- function control_clicked( Obj: PGtkWidget; Sender: PControl ): Boolean; cdecl;
- begin
- if Assigned( Sender.fOnClick ) then
- Sender.fOnClick( Sender );
- Result := FALSE;
- end;
-
- procedure TControl.SetOnClick( const Value: TOnEvent );
- begin
- fOnClick := Value;
- if fEventboxHandle = fHandle then
- begin
- {$IFNDEF SMALLER_CODE}
- if not Assigned( Value ) then
- gtk_signal_disconnect( GTK_OBJECT( fEventboxHandle ), fClickedEvent )
- else
- {$ENDIF SMALLEST_CODE}
- fClickedEvent := gtk_signal_connect( GTK_OBJECT( fEventboxHandle ), 'clicked',
- @ control_clicked, @ Self )
- end
- else
- SetMouseEvent( @ Self, 'button_release_event' );
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
- //////////////////////////////////////////////////////////////////
- // T I M E R
- //////////////////////////////////////////////////////////////////
-
- var {$IFDEF WIN} TimerOwnerWnd: PControl; {$ENDIF} // in Linux, timer not need in a window
- TimerCount: Integer = 0;
-
- { -- Constructor of timer -- }
-
- //[function NewTimer]
- function NewTimer( Interval: Integer ): PTimer;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PTimer.Create;*){--}
- if Interval <= 0 then Interval := 1000;
- Result.fInterval := Interval;
- Inc( TimerCount );
- end;
- //[END NewTimer]
-
- { -- Timer procedure -- }
-
- {$IFDEF WIN}
- //[FUNCTION TimerProc]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TimerProc( Wnd : HWnd; Msg : Integer; T : PTimer; CurrentTime : DWord ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
- if not AppletTerminated then
- {$ENDIF}
- if Assigned( T.fOnTimer ) then
- T.fOnTimer( T );
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
- //[END TimerProc]
- {$ENDIF WIN}
-
- { TTimer }
-
- //[destructor TTimer.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TTimer.Destroy;
- begin
- Enabled := False;
- inherited;
- Dec( TimerCount );
- {$IFDEF WIN}
- if TimerCount = 0 then
- begin
- TimerOwnerWnd.Free;
- TimerOwnerWnd := nil;
- end;
- {$ENDIF WIN}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TTimer.SetEnabled]
- {$IFDEF WIN_GDI}
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TTimer.SetEnabled(const Value: Boolean);
- var WasEnabled: Boolean;
- begin
- WasEnabled := fEnabled;
- fEnabled := Value;
- if WasEnabled = Value then Exit;
- {$IFDEF TIMER_APPLETWND}
- if Applet = nil then Exit;
- {$ENDIF}
-
- if Value then
- begin
- {$IFDEF TIMER_APPLETWND}
- fHandle := SetTimer( Applet.GetWindowHandle, Integer( @Self ),
- fInterval, @TimerProc );
- {$ELSE}
- if TimerOwnerWnd = nil then
- begin
- TimerOwnerWnd := _NewWindowed( nil, {$ifdef wince}'TWND'{$else}''{$endif}, TRUE );
- TimerOwnerWnd.fStyle := 0;
- TimerOwnerWnd.fIsControl := TRUE;
- end;
- fHandle := SetTimer( TimerOwnerWnd.GetWindowHandle, Integer( @Self ),
- fInterval, @TimerProc );
- {$ENDIF}
- end
- else
- begin
- if fHandle <> 0 then
- begin
- KillTimer( {$IFDEF TIMER_APPLETWND} Applet.fHandle
- {$ELSE} TimerOwnerWnd.fHandle {$ENDIF}, fHandle );
- fHandle := 0;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF WIN_GDI}
-
- {$IFDEF _X_}
- {$IFDEF GTK}
- function TimerGTKTick( Sender: Pointer ): LONGBOOL; cdecl;
- begin
- if not PTimer( Sender ).fEnabled then Result := FALSE
- else
- begin
- if Assigned( PTimer( Sender ).fOnTimer ) then
- Ptimer( Sender ).fOnTimer( Sender );
- Result := PTimer( Sender ).fEnabled;
- end;
- if Result then
- PTimer( Sender ).RefDec;
- end;
-
- procedure TTimer.SetEnabled(const Value: Boolean);
- begin
- if FEnabled = Value then Exit;
- fEnabled := Value;
- if Value then
- begin
- RefInc;
- fHandle := gtk_timeout_add( fInterval, TimerGTKTick, @ Self );
- end
- else
- begin
- if AppletTerminated then
- begin
- gtk_timeout_remove( fHandle );
- RefDec;
- end;
- end;
- end;
- {$ELSE not GTK}
- var fActiveTimerList: PTimer;
- fClockPerSecond: Integer;
- fAlarmHandling: Boolean;
-
- procedure SetAlarm; forward;
-
- procedure AlarmHandler(SigNum: Integer); cdecl;
- var T, NT: PTimer;
- c: Integer;
- count_handled: Integer;
- begin
- c := clock;
- fAlarmHandling := TRUE; // to prevent SetAlarm working while timers are handling
- TRY
- //--- 1. Clear fTimerHandled flag for all active timers
- T := fActiveTimerList;
- while T <> nil do
- begin
- T.fTimerHandled := FALSE;
- T := T.fNext;
- end;
- //--- 2. Handle all expired timers
- count_handled := 0;
- while not AppletTerminated do // until all timers expired are handled or
- begin // until the application is terminated
- //--- 2.A. Search a timer which was expired before all others
- T := fActiveTimerList;
- NT := nil;
- while T <> nil do
- begin
- if not T.fTimerHandled and (
- (NT = nil) or ((T.fExpireNext - c) < (NT.fExpireNext - c))
- ) then
- NT := T;
- T := T.fNext;
- end;
- if NT = nil then break; // there are no more timers expired
- if (count_handled > 0) and
- ((NT.fExpireNext - c > 0) or (NT.fExpireNext < 0) and (c > 0)) then break;
- //--- 2.B. Handle found timer (NT)
- inc( count_handled ); // count handled timer to ensure that at least 1 timer
- // was handled in result of alarm call
- {$IFDEF SUPPORT_LONG_TIMER}
- NT.fExpireTotal := NT.fExpireTotal - (c - NT.fTimeStart);
- if NT.fExpireTotal > 30 * 60 * fClockPerSecond then
- NT.fExpireNext := c + 30 * 60 * fClockPerSecond
- else
- NT.fExpireNext := c + NT.fExpireTotal;
- {$ELSE not SUPPORT_LONG_TIMER}
- NT.fExpireNext := // next time to expire this timer
- NT.fExpireNext + fClockPerSecond * NT.fInterval;
- {$ENDIF SUPPORT_LONG_TIMER}
- NT.fTimerHandled := TRUE; // do not handle that timer again in that loop
- {$IFDEF SUPPORT_LONG_TIMER}
- if NT.fExpireTotal <= 0 then
- {$ENDIF SUPPORT_LONG_TIMER}
- begin
- if NT.fMultimedia and not NT.fPeriodic then
- NT.Enabled := FALSE; // one-shot timer, disable it now
- //--------------------------------------------------------------
- //todo: for not a multimedia timer, post a signal to a window
- // to synchronize timer handling with the main thread!
- // (but not for fMultimedia timers)
- //--------------------------------------------------------------
- if Assigned( NT.fOnTimer ) then
- NT.fOnTimer( NT ); // in result of this action, timer NT or any other active
- // timer can be disabled and dropped from fActiveTimerList and any amount of
- // previously disbled timers can be added
- end;
- end;
- FINALLY
- fAlarmHandling := FALSE;
- END;
- // 3. finally, install the next alarm to the nearest expirating timer if any
- SetAlarm;
- end;
-
- procedure SetAlarm;
- var i: Integer;
- T, NT: PTimer;
- TV: itimerval;
- c: clock_t;
- begin
- if AppletTerminated then Exit; // if the application is terminated we do not install alarms
- if fAlarmHandling then Exit; // while alarm is handling do not reinstall alarms
- c := clock;
- T := fActiveTimerList;
- NT := T;
- while T <> nil do
- begin
- if (T.fExpireNext - c) < (NT.fExpireNext - c) then
- NT := T;
- T := T.fNext;
- end;
- if NT = nil then Exit;
- i := (NT.fExpireNext - c) * 1000 div fClockPerSecond;
- if i < 0 then i := 10; // 10 milliseconds as minimum time to alarm
- TV.it_interval.tv_sec := 0; // set interval to alarm once
- TV.it_interval.tv_usec := 0;
- TV.it_value.tv_sec := i div 1000; // set time to alarm next time
- TV.it_value.tv_usec := (i mod 1000) * 1000;
- signal( SIGALRM, AlarmHandler );
- setitimer( ITIMER_REAL, TV, nil );
- end;
-
- procedure TTimer.SetEnabled(const Value: Boolean);
- begin
- if FEnabled = Value then Exit;
- fEnabled := Value;
- if Value then
- begin
- if fClockPerSecond = 0 then
- fClockPerSecond := CLK_TCK;
- fExpireTotal := Int64( fClockPerSecond ) * fInterval;
- {$IFDEF SUPPORT_LONG_TIMER}
- if fExpireTotal > 30 * 60 * fClockPerSecond then
- fExpireNext := clock + 30 * 60 * fClockPerSecond
- else
- fExpireNext := clock + fExpireTotal;
- {$ELSE}
- fExpireNext := clock + fExpireTotal;
- {$ENDIF SUPPORT_LONG_TIMER}
- if fActiveTimerList <> nil then
- begin
- fNext := fActiveTimerList;
- fActiveTimerList.fPrev := @ Self;
- end;
- fActiveTimerList := @ Self;
- end
- else
- begin
- if fPrev <> nil then
- fPrev.fNext := fNext;
- if fNext <> nil then
- fNext.fPrev := fPrev;
- if fActiveTimerList = @ Self then
- fActiveTimerList := fNext;
- fPrev := nil;
- fNext := nil;
- end;
- if fActiveTimerList <> nil then
- begin // set alarm to the nearest expiring timer
- SetAlarm;
- end;
- end;
- {$ENDIF not GTK}
- {$ENDIF _X_}
-
- procedure TTimer.SetInterval(const Value: Integer);
- var WasEnabled : Boolean;
- begin
- if fInterval = Value then Exit;
- fInterval := Value;
- WasEnabled := Enabled;
- Enabled := False;
- Enabled := WasEnabled {$IFDEF STOPTIMER_AFTER_APPLETTERMINATED}
- and not AppletTerminated
- {$ENDIF};
- end;
-
- {$IFDEF WIN}
- {$ifdef win32}
- { TMMTimer }
-
- { ------------ declarations moved here from MMSystem -------------------- }
- const
- TIME_ONESHOT = 0; { program timer for single event }
- TIME_PERIODIC = 1; { program for continuous periodic event }
- TIME_CALLBACK_FUNCTION = $0000; { callback is function }
- TIME_CALLBACK_EVENT_SET = $0010; { callback is event - use SetEvent }
- TIME_CALLBACK_EVENT_PULSE = $0020; { callback is event - use PulseEvent }
-
- type
- TFNTimeCallBack = procedure(uTimerID, uMessage: UINT;
- dwUser, dw1, dw2: DWORD) {$ifdef wince}cdecl{$else}stdcall{$endif};
- //[API timeSetEvent]
- function timeSetEvent(uDelay, uResolution: UINT;
- lpFunction: TFNTimeCallBack; dwUser: DWORD; uFlags: UINT): THandle; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'winmm.dll' name 'timeSetEvent';
- function timeKillEvent(uTimerID: UINT): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'winmm.dll' name 'timeKillEvent';
- { ----------------------------------------------------------------------- }
-
- //[procedure MMTimerCallback]
- procedure MMTimerCallback(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var MMTimer: PMMTimer;
- begin
- MMTimer := Pointer( dwUser );
- if Assigned( MMTimer.FOnTimer ) then
- MMTimer.fOnTimer( MMTimer );
- end;
-
- //[function NewMMTimer]
- function NewMMTimer( Interval: Integer ): PMMTimer;
- begin
- {-}
- New( Result, Create );
- {+} {++}(* Result := PMMTimer.Create; *){--}
- Result.fInterval := Interval;
- Result.FPeriodic := TRUE;
- end;
- //[END NewMMTimer]
-
- //[destructor TMMTimer.Destroy]
- destructor TMMTimer.Destroy;
- begin
- Enabled := FALSE;
- Inc( TimerCount );
- inherited;
- end;
-
- //[procedure TMMTimer.SetEnabled]
- procedure TMMTimer.SetEnabled(const Value: Boolean);
- begin
- if Value xor (fHandle <> 0) then
- begin
- if fHandle = 0 then
- fHandle := timeSetEvent( Interval, Resolution, MMTimerCallback, DWORD( @ Self ),
- Integer( Periodic ) or TIME_CALLBACK_FUNCTION )
- else
- begin
- timeKillEvent( fHandle );
- fHandle := 0;
- end;
- end;
- fEnabled := Value;
- end;
- {$endif win32}
- {$ENDIF WIN}
- {$IFDEF LIN}
- function NewMMTimer( Interval: Integer ): PTimer;
- begin
- Result := NewTimer( Interval );
- {$IFNDEF GTK}
- {$IFNDEF QT}
- Result.fMultimedia := TRUE;
- Result.fPeriodic := TRUE;
- Result.fResolution := 1;
- {$ENDIF QT}
- {$ENDIF GTK}
- end;
- {$ENDIF LIN}
-
- {$IFDEF WIN_GDI} //vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
- ////////////////////////////////////////////////////////////////////////
- // t B I T M A P
- ///////////////////////////////////////////////////////////////////////
-
- { -- bitmap -- }
-
- //[FUNCTION PrepareBitmapHeader]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function PrepareBitmapHeader( W, H, BitsPerPixel: Integer ): PBitmapInfo;
- begin
- Assert( W > 0, 'Width must be >0' );
- Assert( H > 0, 'Height must be >0' );
- Result := AllocMem( 256*Sizeof(TRGBQuad)+Sizeof(TBitmapInfoHeader) );
- Assert( Result <> nil, 'No memory' );
- Result.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
- Result.bmiHeader.biWidth := W;
- Result.bmiHeader.biHeight := H; // may be, -H ?
- Result.bmiHeader.biPlanes := 1;
- Result.bmiHeader.biBitCount := BitsPerPixel;
- end;
- {$ENDIF ASM_VERSION}
- //[END PrepareBitmapHeader]
-
- const
- BitsPerPixel_By_PixelFormat: array[ TPixelFormat ] of Byte =
- ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
-
- //[FUNCTION Bits2PixelFormat]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function Bits2PixelFormat( BitsPerPixel: Integer ): TPixelFormat;
- var I: TPixelFormat;
- begin
- for I := High(I) downto Low(I) do
- if BitsPerPixel = BitsPerPixel_By_PixelFormat[ I ] then
- begin
- Result := I;
- Exit;
- end;
- Result := pfDevice;
- end;
- {$ENDIF ASM_VERSION}
- //[END Bits2PixelFormat]
-
- //[procedure DummyDetachCanvas]
- procedure DummyDetachCanvas( Sender: PBitmap );
- begin
- end;
-
- //[FUNCTION NewBitmap]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewBitmap( W, H: Integer ): PBitmap;
- var DC: HDC;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PBitmap.Create;*){--}
- Result.fHandleType := bmDDB;
- Result.fDetachCanvas := DummyDetachCanvas;
- Result.fWidth := W;
- Result.fHeight := H;
- if (W <> 0) and (H <> 0) then
- begin
- DC := GetDC( 0 );
- Result.fHandle := CreateCompatibleBitmap( DC, W, H );
- Assert( Result.fHandle <> 0, 'Can not create bitmap handle' );
- ReleaseDC( 0, DC );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewBitmap]
-
- const InitColors: array[ 0..17 ] of DWORD = ( $F800, $7E0, $1F, 0, $800000, $8000,
- $808000, $80, $800080, $8080, $808080, $C0C0C0, $FF0000, $FF00, $FFFF00, $FF,
- $FF00FF, $FFFF );
- //[PROCEDURE PreparePF16bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure PreparePF16bit( DIBHeader: PBitmapInfo );
- begin
- DIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
- Move( InitColors[ 0 ], DIBHeader.bmiColors[ 0 ], 19*Sizeof(TRGBQUAD) );
- end;
- {$ENDIF ASM_VERSION}
- //[END PreparePF16bit]
-
- //[FUNCTION NewDIBBitmap]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function NewDIBBitmap( W, H: Integer; PixelFormat: TPixelFormat ): PBitmap;
- const BitsPerPixel: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
- var BitsPixel: Integer;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PBitmap.Create;*){--}
- Result.fDetachCanvas := DummyDetachCanvas;
- Result.fWidth := W;
- Result.fHeight := H;
- if (W <> 0) and (H <> 0) then
- begin
- BitsPixel := BitsPerPixel[ PixelFormat ];
- if BitsPixel = 0 then
- begin
- Result.fNewPixelFormat := DefaultPixelFormat;
- BitsPixel := BitsPerPixel[DefaultPixelFormat];
- end
- else
- Result.fNewPixelFormat := PixelFormat;
- ASSERT( Result.fNewPixelFormat in [ pf1bit..pf32bit ], 'Strange pixel format' );
- Result.fDIBHeader := PrepareBitmapHeader( W, H, BitsPixel );
- if PixelFormat = pf16bit then
- begin
- PreparePF16bit( Result.fDIBHeader );
- end;
-
- Result.fDIBSize := Result.ScanLineSize * H;
- Result.fDIBBits :=
- Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, Result.fDIBSize + 16 ) );
- ASSERT( Result.fDIBBits <> nil, 'No memory' );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END NewDIBBitmap]
-
- { TBitmap }
-
- //[procedure TBitmap.ClearData]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.ClearData;
- begin
- fDetachCanvas( @Self );
- if fHandle <> 0 then
- begin
- DeleteObject( fHandle );
- fHandle := 0;
- fDIBBits := nil;
- end;
- if fDIBBits <> nil then
- begin
- GlobalFree( THandle( fDIBBits ) );
- fDIBBits := nil;
- end;
- if fDIBHeader <> nil then
- begin
- FreeMem( fDIBHeader );
- fDIBHeader := nil;
- end;
- fScanLineSize := 0;
- fGetDIBPixels := nil;
- fSetDIBPixels := nil;
- ClearTransImage;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.Clear]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.Clear;
- begin
- RemoveCanvas;
- ClearData;
- fWidth := 0;
- fHeight := 0;
- fDIBAutoFree := FALSE;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetBoundsRect]
- function TBitmap.GetBoundsRect: TRect;
- begin
- Result := MakeRect( 0, 0, Width, Height );
- end;
-
- //[destructor TBitmap.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TBitmap.Destroy;
- begin
- Clear;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.BitsPerPixel]
- function TBitmap.BitsPerPixel: Integer;
- var B: tagBitmap;
- begin
- CASE PixelFormat OF
- pf1bit: Result := 1;
- pf4bit: Result := 4;
- pf8bit: Result := 8;
- pf15bit: Result := 15;
- pf16bit: Result := 16;
- pf24bit: Result := 24;
- pf32bit: Result := 32;
- else begin
- Result := 0;
- if fHandle <> 0 then
- if GetObject( fHandle, Sizeof( B ), @B ) > 0 then
- Result := B.bmBitsPixel * B.bmPlanes;
- end;
- END;
- end;
-
- //[procedure TBitmap.Draw]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.Draw(DC: HDC; X, Y: Integer);
- var
- DCfrom, DC0: HDC;
- oldBmp: HBitmap;
- oldHeight: Integer;
- B: tagBitmap;
- label
- TRYAgain;
- begin
- TRYAgain:
- if Empty then Exit;
- if fHandle <> 0 then
- begin
- fDetachCanvas( @Self );
- oldHeight := fHeight;
- if GetObject( fHandle, sizeof( B ), @B ) <> 0 then
- oldHeight := B.bmHeight;
- ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
-
- DC0 := GetDC( 0 );
- DCfrom := CreateCompatibleDC( DC0 );
- ReleaseDC( 0, DC0 );
-
- oldBmp := SelectObject( DCfrom, fHandle );
- ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
-
- BitBlt( DC, X, Y, fWidth, oldHeight, DCfrom, 0, 0, SRCCOPY );
- {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
-
- SelectObject( DCfrom, oldBmp );
- DeleteDC( DCfrom );
- end
- else
- if fDIBBits <> nil then
- begin
- oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
- ASSERT( oldHeight > 0, 'oldHeight must be > 0' );
- ASSERT( fWidth > 0, 'Width must be > 0' );
- if StretchDIBits( DC, X, Y, fWidth, oldHeight, 0, 0, fWidth, oldHeight,
- fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY ) = 0 then
- begin
- if GetHandle <> 0 then
- goto TRYAgain;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.StretchDraw]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.StretchDraw(DC: HDC; const Rect: TRect);
- var DCfrom: HDC;
- oldBmp: HBitmap;
- label DrawHandle;
- begin
- if Empty then Exit;
- DrawHandle:
- if fHandle <> 0 then
- begin
- fDetachCanvas( @Self );
- DCfrom := CreateCompatibleDC( 0 );
- oldBmp := SelectObject( DCfrom, fHandle );
- ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
- StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
- Rect.Bottom - Rect.Top, DCfrom, 0, 0, fWidth, fHeight,
- SRCCOPY );
- SelectObject( DCfrom, oldBmp );
- DeleteDC( DCfrom );
- end
- else
- if fDIBBits <> nil then
- begin
- if StretchDIBits( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
- Rect.Bottom - Rect.Top, 0, 0, fWidth, fHeight,
- fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY )<=0 then
- begin
- if GetHandle <> 0 then
- goto DrawHandle;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.DrawMasked]
- procedure TBitmap.DrawMasked(DC: HDC; X, Y: Integer; Mask: HBitmap);
- begin
- StretchDrawMasked( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ), Mask );
- end;
-
- //[procedure TBitmap.DrawTransparent]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.DrawTransparent(DC: HDC; X, Y: Integer; TranspColor: TColor);
- begin
- if TranspColor = clNone then
- Draw( DC, X, Y )
- else
- StretchDrawTransparent( DC, MakeRect( X, Y, X + fWidth, Y + fHeight ),
- TranspColor );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.StretchDrawTransparent]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- {$ifdef wince}
- function TransparentImage(hdcDest : HDC;DstX : LONG;DstY : LONG;DstCx : LONG;DstCy : LONG;hSrc : HANDLE;SrcX : LONG;SrcY : LONG;SrcCx : LONG;SrcCy : LONG;TransparentColor : COLORREF): WINBOOL; cdecl; external KernelDLL name 'TransparentImage';
- {$endif wince}
- procedure TBitmap.StretchDrawTransparent(DC: HDC; const Rect: TRect; TranspColor: TColor);
- begin
- if TranspColor = clNone then
- StretchDraw( DC, Rect )
- else
- begin
- if GetHandle = 0 then Exit;
- TranspColor := Color2RGB( TranspColor );
- {$ifdef wince}
- TransparentImage(DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, fHandle, 0, 0, Width, Height, TranspColor);
- {$else}
- if (fTransMaskBmp = nil) or (fTransColor <> TranspColor) then
- begin
- if fTransMaskBmp = nil then
- fTransMaskBmp := NewBitmap( 0, 0 {fWidth, fHeight} );
- fTransColor := TranspColor;
- // Create here mask bitmap:
- fTransMaskBmp.Assign( @Self );
- fTransMaskBmp.Convert2Mask( TranspColor );
- end;
- StretchDrawMasked( DC, Rect, fTransMaskBmp.Handle );
- {$endif wince}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF DEBUG_DRAWTRANSPARENT}
- procedure DebugDrawTransparent( DC: HDC; X, Y, W, H: Integer; PF: TPixelFormat;
- const Note: String );
- const PixelFormatAsStr: array[ TPixelFormat ] of String = ( 'pfDevice', 'pf1bit',
- 'pf4bit', 'pf8bit', 'pf15bit', 'pf16bit', 'pf24bit', 'pf32bit', 'pfCustom' );
- var Bmp: PBitmap;
- begin
- Bmp := NewDibBitmap( W, H, pf32bit );
- BitBlt( Bmp.Canvas.Handle, 0, 0, W, H, DC, X, Y, SrcCopy );
- Bmp.SaveToFile( GetStartDir + PixelFormatAsStr[ PF ] + Note );
- Bmp.Free;
- end;
- {$ENDIF DEBUG_DRAWTRANSPARENT}
-
- const
- ROP_DstCopy = $00AA0029;
- //[procedure TBitmap.StretchDrawMasked]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.StretchDrawMasked(DC: HDC; const Rect: TRect; Mask: HBitmap);
- var
- DCfrom, MemDC, MaskDC: HDC;
- MemBmp: HBITMAP;
- //Save4From,
- Save4Mem, Save4Mask: THandle;
- crText, crBack: TColorRef;
- {$IFDEF FIX_TRANSPBMPPALETTE}
- FixBmp: PBitmap;
- {$ENDIF FIX_TRANSPBMPPALETTE}
- begin
- {$IFDEF FIX_TRANSPBMPPALETTE}
- if PixelFormat in [ pf4bit, pf8bit ] then
- begin
- FixBmp := NewBitmap( 0, 0 );
- FixBmp.Assign( @ Self );
- FixBmp.PixelFormat := pf32bit;
- FixBmp.StretchDrawMasked( DC, Rect, Mask );
- FixBmp.Free;
- Exit;
- end;
- {$ENDIF FIX_TRANSPBMPPALETTE}
- if GetHandle = 0 then Exit;
- //fDetachCanvas( @Self );
- //DCfrom := CreateCompatibleDC( 0 );
- DCFrom := Canvas.Handle;
- //Save4From := SelectObject( DCfrom, fHandle );
- //ASSERT( Save4From <> 0, 'Can not select source bitmap to DC' );
- MaskDC := CreateCompatibleDC( 0 );
- Save4Mask := SelectObject( MaskDC, Mask );
- ASSERT( Save4Mask <> 0, 'Can not select mask bitmap to DC' );
- MemDC := CreateCompatibleDC( 0 );
- MemBmp := CreateCompatibleBitmap( DCfrom, fWidth, fHeight );
- Save4Mem := SelectObject( MemDC, MemBmp );
- ASSERT( Save4Mem <> 0, 'Can not select memory bitmap to DC' );
- StretchBlt( MemDC, 0, 0, fWidth, fHeight, MaskDC, 0, 0, fWidth, fHeight, SrcCopy);
- {$IFDEF DEBUG_DRAWTRANSPARENT}
- DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '1SrcCopy.bmp' );
- {$ENDIF}
- StretchBlt( MemDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, fWidth, fHeight, SrcErase);
- {$IFDEF DEBUG_DRAWTRANSPARENT}
- DebugDrawTransparent( MemDC, 0, 0, fWidth, fWidth, PixelFormat, '2SrcErase.bmp' );
- {$ENDIF}
- crText := SetTextColor(DC, $0);
- crBack := Windows.SetBkColor(DC, $FFFFFF);
- StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
- MaskDC, 0, 0, fWidth, fHeight, SrcAnd);
- {$IFDEF DEBUG_DRAWTRANSPARENT}
- DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '3SrcAnd.bmp' );
- {$ENDIF}
- StretchBlt( DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
- MemDC, 0, 0, fWidth, fHeight, SrcInvert);
- {$IFDEF DEBUG_DRAWTRANSPARENT}
- DebugDrawTransparent( DC, Rect.Left, Rect.Top, fWidth, fHeight, PixelFormat, '4SrcInvert.bmp' );
- {$ENDIF}
- Windows.SetBkColor( DC, crBack);
- SetTextColor( DC, crText);
- //if Save4Mem <> 0 then
- // SelectObject( MemDC, Save4Mem );
- DeleteObject(MemBmp);
- DeleteDC(MemDC);
- //SelectObject( DCfrom, Save4From );
- //DeleteDC( DCfrom );
- SelectObject( MaskDC, Save4Mask );
- DeleteDC( MaskDC );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure ApplyBitmapBkColor2Canvas]
- procedure ApplyBitmapBkColor2Canvas( Sender: PBitmap );
- begin
- if Sender.fCanvas = nil then Exit;
- Sender.fCanvas.Brush.Color := Sender.BkColor;
- end;
-
- //[PROCEDURE DetachBitmapFromCanvas]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure DetachBitmapFromCanvas( Sender: PBitmap );
- begin
- if Sender.fCanvasAttached = 0 then Exit;
- SelectObject( Sender.fCanvas.fHandle, Sender.fCanvasAttached );
- Sender.fCanvasAttached := 0;
- end;
- {$ENDIF ASM_VERSION}
- //[END DetachBitmapFromCanvas]
-
- //[function TBitmap.GetCanvas]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetCanvas: PCanvas;
- var DC: HDC;
- begin
- Result := nil;
- if Empty then Exit;
- if GetHandle = 0 then Exit;
- if fCanvas = nil then
- begin
- fApplyBkColor2Canvas := ApplyBitmapBkColor2Canvas;
- DC := CreateCompatibleDC( 0 );
- fCanvas := NewCanvas( DC );
- fCanvas.fIsPaintDC := FALSE;
- fCanvas.OnChange := CanvasChanged;
- if fBkColor <> 0 then
- fCanvas.Brush.Color := fBkColor;
- end;
- Result := fCanvas;
-
- if fCanvas.fHandle = 0 then
- begin
- DC := CreateCompatibleDC( 0 );
- fCanvas.Handle := DC;
- fCanvasAttached := 0;
- end;
-
- if fCanvasAttached = 0 then
- begin
- fCanvasAttached := SelectObject( fCanvas.Handle, fHandle );
- ASSERT( fCanvasAttached <> 0, 'Can not select bitmap to DC of Canvas' );
- end;
- fDetachCanvas := DetachBitmapFromCanvas;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetEmpty]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetEmpty: Boolean;
- begin
- Result := (fWidth = 0) or (fHeight = 0);
- ASSERT( (fWidth >= 0) and (fHeight >= 0), 'Bitmap dimensions can be negative' );
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_noVERSION}
- //[function TBitmap.GetHandle]
- function TBitmap.GetHandle: HBitmap;
- asm
- PUSH EBX
- MOV EBX, EAX
- CALL GetEmpty
- JZ @@exit
-
- MOV EAX, EBX
- CALL [EAX].fDetachCanvas
-
- MOV ECX, [EBX].fHandle
- INC ECX
- LOOP @@exit
-
- MOV ECX, [EBX].fDIBBits
- JECXZ @@exit
-
- PUSH ECX
- PUSH 0
- CALL GetDC
- PUSH EAX
- PUSH 0
- PUSH 0
- LEA EDX, [EBX].fDIBBits
- PUSH EDX
- PUSH DIB_RGB_COLORS
- PUSH [EBX].fDIBHeader
- PUSH EAX
- CALL CreateDIBSection
- MOV [EBX].fHandle, EAX
- PUSH 0
- CALL ReleaseDC
- POP EAX
- PUSH EAX
- MOV EDX, [EBX].fDIBBits
- MOV ECX, [EBX].fDIBSize
- CALL System.Move
- POP EAX
- CMP [EBX].fDIBAutoFree, 0
- JNZ @@freed
- PUSH EAX
- CALL GlobalFree
- @@freed:MOV [EBX].fDIBAutoFree, 1
- XOR EAX, EAX
- MOV [EBX].fGetDIBPixels, EAX
- MOV [EBX].fSetDIBPixels, EAX
-
- @@exit: MOV EAX, [EBX].fHandle
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetHandle: HBitmap;
- var OldBits: Pointer;
- DC0: HDC;
- begin
- Result := 0;
- if Empty then Exit;
- fDetachCanvas( @ Self );
- if fHandle = 0 then
- begin
- if fDIBBits <> nil then
- begin
- OldBits := fDIBBits;
- DC0 := GetDC( 0 );
- fDIBBits := nil;
- fHandle := CreateDIBSection( DC0, fDIBHeader^, DIB_RGB_COLORS,
- fDIBBits, 0, 0 );
- {$IFDEF DEBUG}
- if fHandle = 0 then
- ShowMessage( 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
- ', ' + SysErrorMessage( GetLastError ) );
- {$ELSE}
- ASSERT( fHandle <> 0, 'Can not create DIB section, error: ' + Int2Str( GetLastError ) +
- ', ' + SysErrorMessage( GetLastError ) );
- {$ENDIF}
- ReleaseDC( 0, DC0 );
- if fHandle <> 0 then
- begin
- Move( OldBits^, fDIBBits^, fDIBSize );
- if not fDIBAutoFree then
- GlobalFree( THandle( OldBits ) );
- fDIBAutoFree := TRUE;
-
- fGetDIBPixels := nil;
- fSetDIBPixels := nil;
- end
- else
- fDIBBits := OldBits;
- end;
- end;
- Result := fHandle;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetHandleAllocated]
- function TBitmap.GetHandleAllocated: Boolean;
- begin
- Result := fHandle <> 0;
- end;
-
- //[procedure TBitmap.LoadFromFile]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.LoadFromFile(const Filename: KOLString);
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( Filename );
- LoadFromStream( Strm );
- Strm.Free;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.LoadFromResourceID]
- procedure TBitmap.LoadFromResourceID(Inst: DWORD; ResID: Integer);
- begin
- LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ) );
- end;
-
- //[procedure TBitmap.LoadFromResourceName]
- {$IFDEF ASM_UNICODE}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.LoadFromResourceName(Inst: DWORD; ResName: PKOLChar);
- var ResHandle: HBitmap;
- {$ifndef wince}
- Flg: DWORD;
- {$endif wince}
- begin
- Clear;
- {$ifndef wince}
- Flg := 0;
- if fHandleType = bmDIB then
- Flg := LR_CREATEDIBSECTION;
- {$endif wince}
- ResHandle := LoadImage( Inst, ResName, IMAGE_BITMAP, 0, 0, {$ifdef wince} 0 {$else} LR_DEFAULTSIZE or Flg {$endif} );
- if ResHandle = 0 then Exit;
- Handle := ResHandle;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF F_P}
- type
- TBITMAPFILEHEADER = packed record
- bfType: Word;
- bfSize: DWORD;
- bfReserved1: Word;
- bfReserved2: Word;
- bfOffBits: DWORD;
- end;
- {$ENDIF}
-
- {$IFDEF ASM_noVERSION} // error + 16Colors->swap(Gray,Silver) + Core
- //[procedure TBitmap.LoadFromStream]
- procedure TBitmap.LoadFromStream(Strm: PStream);
- type tBFH = TBitmapFileHeader;
- tBIH = TBitmapInfoHeader;
- const szBIH = Sizeof( tBIH );
- szBFH = Sizeof( tBFH );
- asm
- PUSH EBX
- PUSH ESI
- MOV EBX, EAX
- PUSH EDX
- CALL Clear
- POP ESI
- MOV EAX, ESI
- CALL TStream.GetPosition
- PUSH EAX // [EBP+4] = Strm.Pos (starting pos)
- PUSH EBP
- MOV EBP, ESP
- ADD ESP, -(szBIH + szBFH)
-
- // reading bitmap
- XOR ECX, ECX
- MOV [EBX].fHandleType, CL
- MOV CL, szBFH
- MOV EDX, ESP
- PUSH ECX
- MOV EAX, ESI
- CALL TStream.Read
- POP ECX
- SUB ECX, EAX
- JNZ @@eread1
-
- CMP [ESP].tBFH.bfType, $4D42
- JE @@1
- MOV EDX, [EBP+4]
- MOV EAX, ESI
- CALL TStream.Seek
- XOR EAX, EAX
- XOR EDX, EDX
- JMP @@2
-
- @@1:
- MOV EDX, [ESP].tBFH.bfSize
- MOV EAX, [ESP].tBFH.bfOffBits
- @@2:
- PUSH EDX // Push Size
- PUSH EAX // Push Off
- XOR ECX, ECX
- MOV CL, szBIH
- LEA EDX, [EBP-szBIH]
- MOV EAX, ESI
- PUSH ECX
- CALL TStream.Read // read BIH
- POP ECX
- @@eread1:
- XOR ECX, EAX
- JNZ @@eread
-
- MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
- MOVZX EDX, [EBP-szBIH].tBIH.biPlanes
- MUL EDX
- CALL Bits2PixelFormat
- {$IFDEF PARANOIA} DB $3C, pf15bit {$ELSE} CMP AL, pf15bit {$ENDIF}
- JNZ @@no15bit
- CMP [EBP-szBIH].tBIH.biCompression, 0
- JZ @@no15bit
- INC AL // AL = pf16bit
- @@no15bit:
- MOV [EBX].fNewPixelFormat, AL
-
- MOV EAX, szBIH + 1024
- CALL System.@GetMem
- MOV [EBX].fDIBHeader, EAX
- XCHG EDX, EAX
- LEA EAX, [EBP-szBIH]
- XOR ECX, ECX
- MOV CL, szBIH
- CALL System.Move
-
- MOV EAX, [EBP-szBIH].tBIH.biWidth
- MOV [EBX].fWidth, EAX
- MOV EAX, [EBP-szBIH].tBIH.biHeight
- TEST EAX, EAX
- JGE @@20
- NEG EAX
- @@20: MOV [EBX].fHeight, EAX
-
- MOV EAX, EBX
- CALL GetScanLineSize
- MOV EDX, [EBX].fHeight
- MUL EDX
- MOV [EBX].fDIBSize, EAX
- PUSH EAX
- PUSH GMEM_FIXED or GMEM_ZEROINIT
- CALL GlobalAlloc
- MOV [EBX].fDIBBits, EAX
-
- MOVZX EAX, [EBP-szBIH].tBIH.biBitCount
- {$IFDEF PARANOIA} DB $3C, 8 {$ELSE} CMP AL, 8 {$ENDIF}
- JA @@3
- MOV AL, 4
- MOVZX ECX, [EBP-szBIH].tBIH.biBitCount
- SAL EAX, CL
- XCHG ECX, EAX
- @@3:
- CMP [EBX].TBitmap.fNewPixelFormat, pf16bit
- JNE @@30
- XOR ECX, ECX
- MOV CL, 12 // ColorCount = 12
- @@30:
- POP EAX // EAX = off
- TEST EAX, EAX
- JLE @@4
- SUB EAX, szBFH + szBIH
- CMP EAX, ECX
- JZ @@4
- XCHG ECX, EAX
- @@4:
- JECXZ @@5
- PUSH ECX
- MOV EDX, [EBX].fDIBHeader
- ADD EDX, szBIH
- MOV EAX, ESI
- CALL TStream.Read
- POP ECX
- XOR EAX, ECX
- JNZ @@eread
- @@5:
- MOV ECX, [EBX].fDIBSize
- @@7:
- PUSH ECX
- MOV EAX, ESI
- CALL TStream.GetPosition
- PUSH EAX
- MOV EAX, ESI
- CALL TStream.GetSize
- POP EDX
- SUB EAX, EDX
- POP ECX // Size = fDIBSize
- CMP EAX, ECX // Strm.Size - Strm.Position > Size ?
- JL @@8
- XCHG ECX, EAX
- @@8: // ++++++++++++++ 26-Oct-2003 VK see comment in Pascal
- MOV EAX, [EBX].fDIBSize
- CMP ECX, EAX
- JGE @@9
- SUB EAX, ECX
- PUSH EAX
- MOV EAX, ESI
- PUSH ECX
- CALL TStream.GetPosition
- POP ECX
- POP EDX
- CMP EDX, EAX
- JG @@9
-
- MOV EAX, ESI
- NEG EDX
- XOR ECX, ECX
- INC ECX
- CALL TStream.Seek
-
- MOV ECX, [EBX].fDIBSize
- @@9: // ++++++++++++++
- PUSH ECX
- MOV EDX, [EBX].fDIBBits
- MOV EAX, ESI
- CALL TStream.Read
- POP ECX
- XOR EAX, ECX
- POP EAX // Strm.Size - Position
- POP ECX // fDIBSize
- // end of reading bitmap
- @@eread:
- MOV ESP, EBP
- POP EBP
- POP EDX
- JZ @@exit
- // not success:
- XCHG EAX, ESI
- XOR ECX, ECX // ECX = spBegin
- CALL TStream.Seek
- XCHG EAX, EBX
- CALL Clear
- @@exit: POP ESI
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.LoadFromStream(Strm: PStream);
- type
- TColorsArray = array[ 0..15 ] of TColor;
- PColorsArray = ^TColorsArray;
- PColor = ^TColor;
- var Pos : DWORD;
- BFH : TBitmapFileHeader;
-
- function ReadBitmap : Boolean;
- var Size, Size1: Integer;
- BCH: TBitmapCoreHeader;
- RGBSize: DWORD;
- C: PColor;
- Off, HdSz, ColorCount: DWORD;
- //BFHValid: Boolean;
- begin
- fHandleType := bmDIB;
- Result := False;
- //BFHValid := FALSE;
- if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
- Off := 0; Size := 0;
- if BFH.bfType <> $4D42 then
- Strm.Seek( Pos, spBegin )
- else
- begin
- //BFHValid := TRUE;
- Off := BFH.bfOffBits - Sizeof( BFH );
- Size := BFH.bfSize; // don't matter, just <> 0 is good
- end;
- RGBSize := 4;
- HdSz := Sizeof( TBitmapInfoHeader );
- fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + HdSz );
- if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( DWORD ) ) <> Sizeof( DWORD ) then
- Exit;
- if fDIBHeader.bmiHeader.biSize = HdSz then
- begin
- if Strm.Read( fDIBHeader.bmiHeader.biWidth, HdSz - Sizeof( DWORD ) ) <>
- HdSz - Sizeof( DWORD ) then
- Exit;
- end
- else
- if fDIBHeader.bmiHeader.biSize = Sizeof( TBitmapCoreHeader ) then
- begin
- RGBSize := 3;
- HdSz := Sizeof( TBitmapCoreHeader );
- if Strm.Read( BCH.bcWidth, HdSz - Sizeof( DWORD ) ) <>
- HdSz - Sizeof( DWORD ) then
- Exit;
- fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
- fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
- fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
- fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
- fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
- end
- else Exit;
- fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
- * fDIBHeader.bmiHeader.biPlanes );
- if (fNewPixelFormat = pf15bit) and (fDIBHeader.bmiHeader.biCompression <> BI_RGB) then
- begin
- ASSERT( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
- end;
- fWidth := fDIBHeader.bmiHeader.biWidth;
- ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
- fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
- ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
-
- fDIBSize := ScanLineSize * fHeight;
- fDIBBits :=
- Pointer( GlobalAlloc( GMEM_FIXED or GMEM_ZEROINIT, fDIBSize ) );
- ASSERT( fDIBBits <> nil, 'No memory' );
-
- ColorCount := 0;
- if fDIBHeader.bmiHeader.biBitCount <= 8 then
- begin
- if fDIBHeader.bmiHeader.biClrUsed > 0 then
- ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
- else
- ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
- end
- else if (fNewPixelFormat in [ pf16bit ]) or
- (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
- ColorCount := 12;
-
- if Off > 0 then
- begin
- Off := Off - HdSz;
- if (Off <> ColorCount) then
- if not(fNewPixelFormat in [pf15bit,pf16bit])
- or (Off = 0) //+++ to fix loading 15- and 16-bit bmps with mask omitted
- then
- ColorCount := Min( 1024, Off );
- end;
- if ColorCount <> 0 then
- begin
- if Off >= ColorCount then
- Off := Off - ColorCount;
- if RGBSize = 4 then
- begin
- if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
- <> DWORD( ColorCount ) then Exit;
- end
- else
- begin
- C := @ fDIBHeader.bmiColors[ 0 ];
- while ColorCount > 0 do
- begin
- if Strm.Read( C^, RGBSize ) <> RGBSize then Exit;
- Dec( ColorCount, RGBSize );
- Inc( C );
- end;
- end;
- end;
- if Off > 0 then
- Strm.Seek( Off, spCurrent );
- if (Size = 0) or (Strm.Size <= 0) then
- Size := fDIBSize
- else
- Size := Min( fDIBSize, Strm.Size - Strm.Position );
- Size1 := Min( Size, fDIBSize );
-
- if (Size1 < fDIBSize)
- and (DWORD( fDIBSize - Size1 ) <= Strm.Position) then
- begin
- Strm.Seek( Size1 - fDIBSize, spCurrent );
- Size1 := fDIBSize;
- end;
-
- //if BFHValid and (Integer( Strm.Size - BFH.bfOffBits - Pos ) >= Integer( Size )) then
- //if Strm.Position - Pos <= BFH.bfOffbits then
- // Strm.Position := Pos + BFH.bfOffbits;
-
- if Size1 > fDIBSize then Size1 := fDIBSize;
- // +++++++++++++++++++ to fix some "incorrect" bitmaps while loading
-
- if Strm.Read( fDIBBits^, Size1 ) <> DWORD( Size1 ) then Exit;
- if Size > Size1 then
- Strm.Seek( Size - Size1, spCurrent );
-
- Result := True;
- end;
- begin
- Clear;
- Pos := Strm.Position;
- if not ReadBitmap then
- begin
- Strm.Seek( Pos, spBegin );
- Clear;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- ////////////////// bitmap RLE-decoding and loading - by Vyacheslav A. Gavrik
-
- //[procedure DecodeRLE4]
- // by Vyacheslav A. Gavrik
- procedure DecodeRLE4(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
- procedure OddMove(Src,Dst:PByte;Size:Integer);
- begin
- if Size=0 then Exit;
- repeat
- Dst^:=(Dst^ and $F0)or(Src^ shr 4);
- Inc(Dst);
- Dst^:=(Dst^ and $0F)or(Src^ shl 4);
- Inc(Src);
- Dec(Size);
- until Size=0;
- end;
- procedure OddFill(Mem:PByte;Size,Value:Integer);
- begin
- Value:=(Value shr 4)or(Value shl 4);
- Mem^:=(Mem^ and $F0)or(Value and $0F);
- Inc(Mem);
- if Size>1 then FillChar(Mem^,Size,Char( Value ))
- else Mem^:=(Mem^ and $0F)or(Value and $F0);
- end;
- var
- pb: PByte;
- x,y,z,i: Integer;
- begin
- pb:=Data; x:=0; y:=0;
- if Bmp.fScanLineSize = 0 then
- Bmp.ScanLineSize;
- while (y<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
- begin
- if pb^=0 then
- begin
- Inc(pb);
- z:=pb^;
- case pb^ of
- 0: begin
- Inc(y);
- x:=0;
- end;
- 1: Break;
- 2: begin
- Inc(pb); Inc(x,pb^);
- Inc(pb); Inc(y,pb^);
- end;
- else
- begin
- Inc(pb);
- i:=(z+1)shr 1;
- if i and 1 = 1 then Inc( i );
- if x + z <= bmp.Width then
- if x and 1 =1 then
- OddMove(pb,@PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x shr 1],(z+1)shr 1)
- else
- Move(pb^,PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x shr 1],(z+1)shr 1);
- Inc(pb,i-1);
- Inc(x,z);
- end;
- end;
- end else
- begin
- z:=pb^;
- Inc(pb);
- if x + z <= Bmp.Width then
- if x and 1 = 1 then
- OddFill(@PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x shr 1],(z+1) shr 1,pb^)
- else
- FillChar( PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x shr 1],
- (z+1) shr 1, Char( pb^ ));
- Inc(x,z);
- end;
- Inc(pb);
- end;
- end;
-
- //[procedure DecodeRLE8]
- // by Vyacheslav A. Gavrik
- procedure DecodeRLE8(Bmp:PBitmap;Data:Pointer; MaxSize: DWORD);
- var
- pb: PByte;
- x,y,z,i: Integer;
- begin
- pb:=Data; y:=0; x:=0;
- if Bmp.fScanLineSize = 0 then
- Bmp.ScanLineSize;
-
- while (y<Bmp.Height) and (DWORD(pb) - DWORD(Data) < MaxSize) do
- begin
- if pb^=0 then
- begin
- Inc(pb);
- case pb^ of
- 0: begin
- Inc(y);
- x:=0;
- end;
- 1: Break;
- 2: begin
- Inc(pb); Inc(x,pb^);
- Inc(pb); Inc(y,pb^);
- end;
- else
- begin
- i:=pb^;
- z:=(i+1)and(not 1);
- Inc(pb);
- Move(pb^,PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x],i);
- Inc(pb,z-1);
- Inc(x,i);
- end;
- end;
- end else
- begin
- i:=pb^; Inc(pb);
- if x + i <= Bmp.Width then
- FillChar( PByteArray(cardinal( Bmp.fDIBBits ) + cardinal(Bmp.fScanLineSize * y))[x],
- i, Char( pb^ ));
- Inc(x,i);
- end;
- Inc(pb);
- end;
- end;
-
- //[function TBitmap.LoadFromFileEx]
- function TBitmap.LoadFromFileEx(const Filename: KOLString): Boolean; // by Vyacheslav A. Gavrik
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( Filename );
- Result := LoadFromStreamEx(Strm);
- Strm.Free;
- end;
-
- //[function TBitmap.LoadFromStreamEx]
- function TBitmap.LoadFromStreamEx(Strm: PStream): Boolean; // by Vyacheslav A. Gavrik
- var Pos : DWORD;
- i: Integer;
-
- function ReadBitmap : Boolean;
- var Off, Size, ColorCount: Integer;
- BFH : TBitmapFileHeader;
- BCH: TBITMAPCOREHEADER;
- BFHValid: Boolean;
- Buffer: Pointer;
- L: DWORD;
- ColorTriples: Boolean;
- PColr: PDWORD;
- FinalPos: DWORD;
- ZI: DWORD;
- begin
- fHandleType := bmDIB;
- Result := False;
- BFHValid := FALSE;
- if Strm.Read( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
- Off := 0; Size := 0;
- ColorTriples := FALSE;
- if BFH.bfType <> $4D42 then
- begin
- Strm.Seek( Pos, spBegin );
- BFH.bfOffBits := 0;
- BFH.bfSize := 0;
- end
- else
- begin
- BFHValid := TRUE;
- Off := BFH.bfOffBits;
- Size := BFH.bfSize;
- end;
- fDIBHeader := AllocMem( 256*sizeof(TRGBQuad) + sizeof(TBitmapInfoHeader) );
- if Strm.Read( fDIBHeader.bmiHeader.biSize, Sizeof( fDIBHeader.bmiHeader.biSize ) ) <>
- Sizeof( fDIBHeader.bmiHeader.biSize ) then Exit;
- if (fDIBHeader.bmiHeader.biSize <> Sizeof( TBITMAPCOREHEADER )) and
- (fDIBHeader.bmiHeader.biSize <> Sizeof( TBitmapInfoHeader )) then Exit;
- L := fDIBHeader.bmiHeader.biSize - Sizeof( fDIBHeader.bmiHeader.biSize );
- if (fDIBHeader.bmiHeader.biSize = Sizeof( TBITMAPCOREHEADER )) then
- begin
- if Strm.Read( BCH.bcWidth, L ) <> L then Exit;
- fDIBHeader.bmiHeader.biSize := Sizeof( TBitmapInfoHeader );
- fDIBHeader.bmiHeader.biWidth := BCH.bcWidth;
- fDIBHeader.bmiHeader.biHeight := BCH.bcHeight;
- fDIBHeader.bmiHeader.biPlanes := BCH.bcPlanes;
- fDIBHeader.bmiHeader.biBitCount := BCH.bcBitCount;
- ColorTriples := TRUE;
- end
- else
- begin
- if Strm.Read( fDIBHeader.bmiHeader.biWidth, L) <> L then
- Exit;
- end;
-
- fNewPixelFormat := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount
- * fDIBHeader.bmiHeader.biPlanes );
- //if fNewPixelFormat = pf15bit then fNewPixelFormat := pf16bit;
-
- fWidth := fDIBHeader.bmiHeader.biWidth;
- ASSERT( fWidth > 0, 'Bitmap width must be > 0' );
- fHeight := Abs(fDIBHeader.bmiHeader.biHeight);
- ASSERT( fHeight > 0, 'Bitmap height must be > 0' );
-
- fDIBSize := ScanLineSize * fHeight;
- ZI := 0;
- if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
- (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
- ZI := GMEM_ZEROINIT;
- fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED or ZI, fDIBSize + 4 ) );
- ASSERT( fDIBBits <> nil, 'No memory' );
- ASSERT( (fDIBHeader.bmiHeader.biCompression and
- (BI_RLE8 or BI_RLE4 or BI_RLE8 or BI_BITFIELDS) <> 0) or
- (fDIBHeader.bmiHeader.biCompression = BI_RGB),
- 'Unknown compression algorithm');
-
- ColorCount := 0;
- if fDIBHeader.bmiHeader.biBitCount <= 8 then
- begin
- if fDIBHeader.bmiHeader.biClrUsed > 0 then
- ColorCount := fDIBHeader.bmiHeader.biClrUsed * Sizeof( TRGBQuad )
- else
- ColorCount := (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad )
- end
- else if (fNewPixelFormat in [ pf15bit, pf16bit ]) or
- (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
- begin
- if (Strm.Size = 0) or (Strm.Size - Strm.Position - DWORD( Size ) >= 12) then
- ColorCount := 12;
- end;
-
- if ColorTriples then
- ColorCount := ColorCount div 4 * 3;
-
- if Off > 0 then
- begin
- Off := Off - SizeOf( TBitmapFileHeader ) - Sizeof( TBitmapInfoHeader );
- if (Off <> ColorCount) and (fNewPixelFormat <= pf8bit) then
- if ColorTriples then
- ColorCount := min( Off, 3 * 256 )
- else
- ColorCount := min( Off, 4 * 256 );
- end;
- if (fNewPixelFormat in [ pf15bit, pf16bit ]) then
- if (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
- begin
- PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := ( $00001F );
- PDWORD( DWORD( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := ( $0007E0 );
- TColor( fDIBHeader.bmiColors[ 0 ] ) := ( $00F800 );
- end
- else
- begin
- ColorCount := 0;
- end;
-
- if ColorCount <> 0 then
- if ColorTriples then
- begin
- PColr := @ fDIBheader.bmiColors[ 0 ];
- while ColorCount >= 3 do
- begin
- if strm.Read( PColr^, 3 ) <> 3 then Exit;
- Inc( PColr );
- Dec( ColorCount, 3 );
- end;
- end
- else
- begin
- if (Integer( Strm.Size - Strm.Position ) > fDIBSize) or
- (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
- (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
- begin
- if Strm.Read( fDIBheader.bmiColors[ 0 ], ColorCount )
- <> DWORD( ColorCount ) then Exit;
- if Off - ColorCount > 0 then
- Strm.Position := Integer( Strm.Position ) + Off - ColorCount;
- end;
- end;
-
- if not BFHValid then
- Size := fDIBSize
- else
- if (fDIBHeader.bmiHeader.biCompression = BI_RLE8) or
- (fDIBHeader.bmiHeader.biCompression = BI_RLE4) then
- begin
- //if BFHValid then //-- already TRUE here
- Size := BFH.bfSize - BFH.bfOffBits;
- end
- else
- begin
- if (Strm.Size = 0) or
- (Integer( Strm.Size - BFH.bfOffBits - Pos ) > Integer(Size)) then
- Size := fDIBSize
- else
- Size := Strm.Size - BFH.bfOffBits - DWORD( Pos );
- if Size > fDIBSize then Size := fDIBSize
- else if (Size < fDIBSize) and (fDIBheader.bmiHeader.biClrUsed <> 0) then
- begin
- BFHValid := FALSE;
- Strm.Position := Strm.Position + fDIBheader.bmiHeader.biClrUsed * 4;
- Size := Strm.Size - Strm.Position;
- end;
- end;
-
- if (fDIBHeader.bmiHeader.biCompression = BI_RGB) or
- (fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS) then
- begin
- if BFHValid and
- ( (Strm.Size > 0) and
- (Integer( Strm.Size - BFH.bfOffBits - Pos) > Integer(Size))
- or
- (Strm.Size = 0) and
- (Off > 0)
- ) then
- if Integer( Strm.Position - Pos ) <= Integer( BFH.bfOffbits ) then
- Strm.Position := Pos + BFH.bfOffbits;
- i := Strm.Read( fDIBBits^, Size );
- if i <> Size then
- begin
- //Exit;
- {$IFDEF FILL_BROKEN_BITMAP}
- FillChar( Pointer( Integer( fDIBBits ) + i )^,
- Size - i, #0 );
- {$ENDIF FILL_BROKEN_BITMAP}
- end;
- end
- else
- begin
- if (Integer( fDIBHeader.bmiHeader.biSizeImage ) > 0) and
- (Integer( fDIBHeader.bmiHeader.biSizeImage ) < Size) then
- Size := Integer( fDIBHeader.bmiHeader.biSizeImage ); // - ColorCount;
-
- // it is possible that bitmap "compressed" with RLE has size
- // greater then non-compressed one:
- FinalPos := Strm.Position + DWORD( Size );
-
- //Size := Size * 3;
- L := Strm.Size - Strm.Position;
- if L > DWORD( Size ) then
- L := Size;
-
- Buffer := AllocMem( Size * 3 );
- if Strm.Read(Buffer^,L) <> DWORD( L ) then ; //Exit;
-
- if fDIBHeader.bmiHeader.biCompression=BI_RLE8 then
- DecodeRLE8(@Self,Buffer,Size * 3)
- else
- DecodeRLE4(@Self,Buffer,Size * 3);
-
- Strm.Position := FinalPos;
-
- fDIBHeader.bmiHeader.biCompression := BI_RGB;
- FreeMem(Buffer);
- end;
-
- Result := True;
- end;
- begin
- Clear;
- Pos := Strm.Position;
- result := ReadBitmap;
- if not result then
- begin
- Strm.Seek( Pos, spBegin );
- Clear;
- end;
- end;
-
- ///////////////////////////
-
- //[function TBitmap.ReleaseHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.ReleaseHandle: HBitmap;
- var OldBits: Pointer;
- begin
- HandleType := bmDIB;
- Result := GetHandle;
- if Result = 0 then Exit; // only when bitmap is empty
- if fDIBAutoFree then
- begin
- OldBits := fDIBBits;
- fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
- Move( OldBits^, fDIBBits^, fDIBSize );
- fDIBAutoFree := FALSE;
- end;
- fHandle := 0;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SaveToFile]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SaveToFile(const Filename: KOLString);
- var Strm: PStream;
- begin
- if Empty then Exit;
- Strm := NewWritefileStream( Filename );
- SaveToStream( Strm );
- Strm.Free;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SaveToStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SaveToStream(Strm: PStream);
- var BFH : TBitmapFileHeader;
- Pos : Integer;
- function WriteBitmap : Boolean;
- var ColorsSize, BitsSize, Size : Integer;
- begin
- Result := False;
- if Empty then Exit;
- HandleType := bmDIB; // convert to DIB if DDB
- FillChar( BFH, Sizeof( BFH ), 0 );
- ColorsSize := 0;
- with fDIBHeader.bmiHeader do
- if biBitCount <= 8 then
- ColorsSize := (1 shl biBitCount) * Sizeof( TRGBQuad );
- BFH.bfOffBits := Sizeof( BFH ) + Sizeof( TBitmapInfoHeader ) + ColorsSize;
- BitsSize := fDIBSize; //ScanLineSize * fHeight;
- BFH.bfSize := BFH.bfOffBits + DWord( BitsSize );
- BFH.bfType := $4D42; // 'BM';
- if fDIBHeader.bmiHeader.biCompression <> 0 then
- begin
- ColorsSize := 12 + 16*sizeof(TRGBQuad);
- Inc( BFH.bfOffBits, ColorsSize );
- end;
- if Strm.Write( BFH, Sizeof( BFH ) ) <> Sizeof( BFH ) then Exit;
- Size := Sizeof( TBitmapInfoHeader ) + ColorsSize;
- if Strm.Write( fDIBHeader^, Size ) <> DWORD(Size) then Exit;
- if Strm.Write( fDIBBits^, BitsSize ) <> DWord( BitsSize ) then Exit;
- Result := True;
- end;
- begin
- Pos := Strm.Position;
- if not WriteBitmap then
- Strm.Seek( Pos, spBegin );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetHandle]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetHandle(const Value: HBitmap);
- var B: tagBitmap;
- Dib: TDIBSection;
- begin
- Clear;
- if Value = 0 then Exit;
- if (WinVer >= wvNT) and
- (GetObject( Value, Sizeof( Dib ), @ Dib ) = Sizeof( Dib )) then
- begin
- fHandle := Value;
- fHandleType := bmDIB;
- fDIBHeader := PrepareBitmapHeader( Dib.dsBm.bmWidth, Dib.dsBm.bmHeight,
- Dib.dsBm.bmBitsPixel );
- Move( Dib.dsBitfields, fDIBHeader.bmiColors, 3 * 4 );
- fWidth := Dib.dsBm.bmWidth;
- fHeight := Dib.dsBm.bmHeight;
- fDIBBits := Dib.dsBm.bmBits;
- fDIBSize := Dib.dsBmih.biSizeImage;
- fDIBAutoFree := true;
- {$ifdef wince}
- if fDIBBits = nil then
- HandleType:=bmDDB;
- {$endif wince}
- end
- else
- begin
- if GetObject( Value, Sizeof( B ), @B ) = 0 then Exit;
- fHandle := Value;
- fWidth := B.bmWidth;
- fHeight := B.bmHeight;
- fHandleType := bmDDB;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetWidth]
- procedure TBitmap.SetWidth(const Value: Integer);
- begin
- if fWidth = Value then Exit;
- fWidth := Value;
- FormatChanged;
- end;
-
- //[procedure TBitmap.SetHeight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetHeight(const Value: Integer);
- begin
- if fHeight = Value then Exit;
-
- HandleType := bmDDB;
- // Not too good, but provides correct changing of height
- // preserving previous image
-
- fHeight := Value;
- FormatChanged;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetPixelFormat]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetPixelFormat(Value: TPixelFormat);
- begin
- if PixelFormat = Value then Exit;
- if Empty then Exit;
- if Value = pfDevice then
- HandleType := bmDDB
- else
- begin
- fNewPixelFormat := Value;
- fHandleType := bmDIB;
- FormatChanged;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION CalcScanLineSize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function CalcScanLineSize( Header: PBitmapInfoHeader ): Integer;
- begin
- Result := ((Header.biBitCount * Header.biWidth + 31) shr 3) and $FFFFFFFC;
- end;
- {$ENDIF ASM_VERSION}
- //[END CalcScanLineSize]
-
- //[PROCEDURE FillBmpWithBkColor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure FillBmpWithBkColor( Bmp: PBitmap; DC2: HDC; oldWidth, oldHeight: Integer );
- var oldBmp: HBitmap;
- R: TRect;
- Br: HBrush;
- begin
- with Bmp{-}^{+} do
- if Color2RGB( fBkColor ) <> 0 then
- if (oldWidth < fWidth) or (oldHeight < fHeight) then
- if GetHandle <> 0 then
- begin
- oldBmp := SelectObject( DC2, fHandle );
- ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
- Br := CreateSolidBrush( Color2RGB( fBkColor ) );
- R := MakeRect( oldWidth, oldHeight, fWidth, fHeight );
- if oldWidth = fWidth then
- R.Left := 0;
- if oldHeight = fHeight then
- R.Top := 0;
- Windows.FillRect( DC2, R, Br );
- DeleteObject( Br );
- SelectObject( DC2, oldBmp );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END FillBmpWithBkColor]
-
- const BitCounts: array[ TPixelFormat ] of Byte = ( 0, 1, 4, 8, 16, 16, 24, 32, 0 );
-
- //[procedure TBitmap.FormatChanged]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.FormatChanged;
- // This method is used whenever Width, Height, PixelFormat or HandleType
- // properties are changed.
- // Old image will be drawn here to a new one (excluding cases when
- // old width or height was 0, and / or new width or height is 0).
- // To avoid inserting this code into executable, try not to change
- // properties Width / Height of bitmat after it is created using
- // NewBitmap( W, H ) function or after it is loaded from file, stream
- // or resource.
-
- var B: tagBitmap;
- oldBmp, NewHandle: HBitmap;
- DC0, DC2: HDC;
- oldHeight, oldWidth: Integer;
- Br: HBrush;
- NewHeader: PBitmapInfo;
- NewBits: Pointer;
- sizeBits, bitsPixel: Integer;
- NewDIBAutoFree: Boolean;
- {$ifndef wince}
- N: Integer;
- Hndl: THandle;
- {$endif wince}
- begin
- if Empty then Exit;
- {$ifndef wince}
- NewDIBAutoFree := FALSE;
- {$endif wince}
- fDetachCanvas( @Self );
- fScanLineSize := 0;
- fGetDIBPixels := nil;
- fSetDIBPixels := nil;
-
- oldWidth := fWidth;
- oldHeight := fHeight;
- if fDIBBits <> nil then
- begin
- oldWidth := fDIBHeader.bmiHeader.biWidth;
- oldHeight := Abs(fDIBHeader.bmiHeader.biHeight);
- end
- else
- if fHandle <> 0 then
- begin
- if GetObject( fHandle, Sizeof( B ), @ B ) <> 0 then
- begin
- oldWidth := B.bmWidth;
- oldHeight := B.bmHeight;
- end;
- end;
-
- DC2 := CreateCompatibleDC( 0 );
-
- if fHandleType = bmDDB then
- begin
- // New HandleType is bmDDB: old bitmap can be copied using Draw method
- DC0 := GetDC( 0 );
- NewHandle := CreateCompatibleBitmap( DC0, fWidth, fHeight );
- ASSERT( NewHandle <> 0, 'Can not create DDB' );
- ReleaseDC( 0, DC0 );
-
- oldBmp := SelectObject( DC2, NewHandle );
- ASSERT( oldBmp <> 0, 'Can not select bitmap to DC' );
-
- Br := CreateSolidBrush( Color2RGB( fBkColor ) );
- FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
- DeleteObject( Br );
- {$ifdef win32}
- if fDIBBits <> nil then
- begin
- SelectObject( DC2, oldBmp );
- SetDIBits( DC2, NewHandle, 0, fHeight, fDIBBits, fDIBHeader^, DIB_RGB_COLORS );
- end
- else
- {$endif win32}
- begin
- Draw( DC2, 0, 0 );
- SelectObject( DC2, oldBmp );
- end;
-
- ClearData; // Image is cleared but fWidth and fHeight are preserved
- fHandle := NewHandle;
- end
- else
- begin
- // New format is DIB. GetDIBits applied to transform old data to new one.
- if fNewPixelFormat = pfDevice then
- bitsPixel := GetDeviceCaps( DC2, Windows.BITSPIXEL )*GetDeviceCaps( DC2, PLANES )
- else
- bitsPixel := BitCounts[ fNewPixelFormat ];
- if bitsPixel = 0 then
- bitsPixel := BitCounts[DefaultPixelFormat];
-
- NewHandle := 0;
- NewHeader := PrepareBitmapHeader( fWidth, fHeight, bitsPixel );
- if bitsPixel = 16 then
- PreparePF16bit( NewHeader );
-
- sizeBits := CalcScanLineSize( @NewHeader.bmiHeader ) * fHeight;
- {$ifndef wince}
- NewBits := Pointer( GlobalAlloc( GMEM_FIXED, sizeBits ) );
- ASSERT( NewBits <> nil, 'No memory' );
-
- Hndl := GetHandle;
- if Hndl = 0 then Exit;
- N :=
- GetDIBits( DC2, Hndl, 0, Min( fHeight, oldHeight ),
- NewBits, NewHeader^, DIB_RGB_COLORS );
- if N <> Min( fHeight, oldHeight ) then
- begin
- GlobalFree( DWORD( NewBits ) );
- {$endif wince}
- NewBits := nil;
- NewHandle := CreateDIBSection( DC2, NewHeader^, DIB_RGB_COLORS, NewBits, 0, 0 );
- NewDIBAutoFree := TRUE;
- ASSERT( NewHandle <> 0, 'Can not create DIB secion for pf16bit bitmap' );
- oldBmp := SelectObject( DC2, NewHandle );
- ASSERT( oldBmp <> 0, 'Can not select pf16bit to DC' );
- Draw( DC2, 0, 0 );
- SelectObject( DC2, oldBmp );
- {$ifndef wince}
- end;
- {$endif wince}
- ClearData;
- fDIBSize := sizeBits;
- fDIBBits := NewBits;
- fDIBHeader := NewHeader;
- fHandle := NewHandle;
- fDIBAutoFree := NewDIBAutoFree;
- end;
-
- if Assigned( fFillWithBkColor ) then
- fFillWithBkColor( @Self, DC2, oldWidth, oldHeight );
-
- DeleteDC( DC2 );
-
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetScanLine]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetScanLine(Y: Integer): Pointer;
- begin
- ASSERT( (Y >= 0) {and (Y < fHeight)}, 'ScanLine index out of bounds' );
- ASSERT( fDIBBits <> nil, 'No bits available' );
- Result := nil;
- if fDIBHeader = nil then Exit;
-
- if fDIBHeader.bmiHeader.biHeight > 0 then
- Y := fHeight - 1 - Y;
- if fScanLineSize = 0 then
- ScanLineSize;
-
- Result := Pointer( cardinal( fDIBBits ) + cardinal(fScanLineSize * Y) );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetScanLineSize]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetScanLineSize: Integer;
- begin
- Result := 0;
- if fDIBHeader = nil then Exit;
- FScanLineSize := CalcScanLineSize( @fDIBHeader.bmiHeader );
- Result := FScanLineSize;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.CanvasChanged]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.CanvasChanged( Sender : PObj );
- begin
- fBkColor := PCanvas( Sender ).Brush.Color;
- ClearTransImage;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.Dormant]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.Dormant;
- begin
- RemoveCanvas;
- if fHandle <> 0 then
- DeleteObject( ReleaseHandle );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetBkColor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetBkColor(const Value: TColor);
- begin
- if fBkColor = Value then Exit;
- fBkColor := Value;
- fFillWithBkColor := FillBmpWithBkColor;
- if Assigned( fApplyBkColor2Canvas ) then
- fApplyBkColor2Canvas( @Self );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.Assign]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.Assign(SrcBmp: PBitmap): Boolean;
- {$ifdef wince}
- var
- DC: HDC;
- OldBmp: HBITMAP;
- {$endif wince}
- begin
- Clear;
- Result := False;
- if SrcBmp = nil then Exit;
- if SrcBmp.Empty then Exit;
- fWidth := SrcBmp.fWidth;
- fHeight := SrcBmp.fHeight;
- fHandleType := SrcBmp.fHandleType;
- if SrcBmp.fHandleType = bmDDB then
- begin
- {$ifdef wince}
- DC := GetDC( 0 );
- fHandle := CreateCompatibleBitmap( DC, fWidth, fHeight );
- ReleaseDC( 0, DC );
- DC:=CreateCompatibleDC(0);
- OldBmp:=SelectObject(DC, fHandle);
- SrcBmp.Draw(DC, 0, 0);
- SelectObject(DC, OldBmp);
- DeleteDC(DC);
- {$else}
- fHandle := CopyImage( SrcBmp.fHandle, IMAGE_BITMAP, 0, 0, 0 {LR_COPYRETURNORG} );
- ASSERT( fHandle <> 0, 'Can not copy bitmap image' );
- {$endif wince}
- Result := fHandle <> 0;
- if not Result then Clear;
- end
- else
- begin
- GetMem( fDIBHeader, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
- ASSERT( fDIBHeader <> nil, 'No memory' );
- Move( SrcBmp.fDIBHeader^, fDIBHeader^, Sizeof(TBitmapInfoHeader) + 256*sizeof(TRGBQuad) );
- fDIBSize := SrcBmp.fDIBSize;
- fDIBBits := Pointer( GlobalAlloc( GMEM_FIXED {or GMEM_ZEROINIT}, fDIBSize ) );
- ASSERT( fDIBBits <> nil, 'No memory' );
- Move( SrcBmp.fDIBBits^, fDIBBits^, fDIBSize );
- Result := True;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.RemoveCanvas]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.RemoveCanvas;
- begin
- fDetachCanvas( @Self );
- fCanvas.Free;
- fCanvas := nil;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.DIBPalNearestEntry]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.DIBPalNearestEntry(Color: TColor): Integer;
- var I, Diff, D: Integer;
- C : Integer;
- begin
- Color := TColor( Color2RGBQuad( Color ) );
- Result := 0;
- Diff := MaxInt;
- for I := 0 to DIBPalEntryCount - 1 do
- begin
- C := Color xor PInteger( cardinal( @fDIBHeader.bmiColors[ 0 ] )
- + cardinal(I * Sizeof( TRGBQuad )) )^;
- D := TRGBQuad( C ).rgbBlue + TRGBQuad( C ).rgbGreen + TRGBQuad( C ).rgbRed;
- if D < Diff then
- begin
- Diff := D;
- Result := I;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetDIBPalEntries]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetDIBPalEntries(Idx: Integer): TColor;
- begin
- Result := TColor(-1);
- if fDIBBits = nil then Exit;
- ASSERT( PixelFormat in [pf1bit..pf8bit], 'Format has no DIB palette entries available' );
- ASSERT( (Idx >= 0) and (Idx < (1 shl fDIBHeader.bmiHeader.biBitCount)),
- 'DIB palette index out of bounds' );
- Result := PDWORD( cardinal( @fDIBHeader.bmiColors[ 0 ] )
- + cardinal(Idx * Sizeof( TRGBQuad ) ))^;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.GetDIBPalEntryCount]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetDIBPalEntryCount: Integer;
- begin
- Result := 0;
- if Empty then Exit;
- case PixelFormat of
- pf1bit: Result := 2;
- pf4bit: Result := 16;
- pf8bit: Result := 256;
- else;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetDIBPalEntries]
- procedure TBitmap.SetDIBPalEntries(Idx: Integer; const Value: TColor);
- begin
- if fDIBBits = nil then Exit;
- Dormant;
- PDWORD( cardinal( @fDIBHeader.bmiColors[ 0 ] )
- + cardinal(Idx * Sizeof( TRGBQuad )) )^ := Color2RGB( Value );
- end;
-
- //[procedure TBitmap.SetHandleType]
- procedure TBitmap.SetHandleType(const Value: TBitmapHandleType);
- begin
- if fHandleType = Value then Exit;
- fHandleType := Value;
- FormatChanged;
- end;
-
- //[function TBitmap.GetPixelFormat]
- function TBitmap.GetPixelFormat: TPixelFormat;
- begin
- if (HandleType = bmDDB) or (fDIBBits = nil) then
- Result := pfDevice
- else
- begin
- Result := Bits2PixelFormat( fDIBHeader.bmiHeader.biBitCount );
- if fDIBHeader.bmiHeader.biCompression <> 0 then
- begin
- Assert( fDIBHeader.bmiHeader.biCompression = BI_BITFIELDS, 'Unsupported bitmap format' );
- if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $F800) and
- (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $7E0) and
- (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
- Result := pf16bit
- else
- if (TColor( fDIBHeader.bmiColors[ 0 ] ) = $7C00) and
- (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+4 )^ = $3E0) and
- (PInteger( DWORD(@ fDIBHeader.bmiColors[ 0 ])+8 )^ = $1F) then
- Result := pf15bit
- else
- Result := pfCustom;
- end;
- end;
- end;
-
- //[procedure TBitmap.ClearTransImage]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.ClearTransImage;
- begin
- fTransColor := clNone;
- fTransMaskBmp.Free;
- fTransMaskBmp := nil;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.Convert2Mask]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- {$IFDEF USE_OLDCONVERT2MASK}
- procedure TBitmap.Convert2Mask(TranspColor: TColor);
- var MonoHandle: HBitmap;
- SaveMono, SaveFrom: THandle;
- MonoDC, {DC0,} DCfrom: HDC;
- SaveBkColor: TColorRef;
- begin
- if GetHandle = 0 then Exit;
- fDetachCanvas( @Self );
- ///DC0 := GetDC( 0 );
- MonoHandle := CreateBitmap( fWidth, fHeight, 1, 1, nil );
- ASSERT( MonoHandle <> 0, 'Can not create monochrome bitmap' );
- MonoDC := CreateCompatibleDC( 0 );
- SaveMono := SelectObject( MonoDC, MonoHandle );
- ASSERT( SaveMono <> 0, 'Can not select bitmap to DC' );
- DCfrom := CreateCompatibleDC( 0 );
- SaveFrom := SelectObject( DCfrom, fHandle );
- ASSERT( SaveFrom <> 0, 'Can not select source bitmap to DC' );
- TranspColor := Color2RGB( TranspColor );
- SaveBkColor := Windows.SetBkColor( DCfrom, TranspColor );
- BitBlt( MonoDC, 0, 0, fWidth, fHeight, DCfrom, 0, 0, SRCCOPY );
- {$IFDEF CHK_BITBLT} Chk_BitBlt; {$ENDIF}
- Windows.SetBkColor( DCfrom, SaveBkColor );
- SelectObject( DCfrom, SaveFrom );
- DeleteDC( DCfrom );
- SelectObject( MonoDC, SaveMono );
- DeleteDC( MonoDC );
- ///ReleaseDC( 0, DC0 );
- ClearData;
- fHandle := MonoHandle;
- fHandleType := bmDDB;
- end;
- {$ELSE NOT USE_OLDCONVERT2MASK} //Pascal
- procedure TBitmap.Convert2Mask(TranspColor: TColor);
- var Y, X, i: Integer;
- Src, Dst: PByte;
- W: Word;
- TmpMsk: PBitmap;
- B, C: Byte;
- TranspColor32: TColor;
- begin
- HandleType := bmDIB;
- if PixelFormat < pf4bit then
- PixelFormat := pf4bit;
- if PixelFormat > pf32bit then
- PixelFormat := pf32bit;
- TranspColor := Color2RGB( TranspColor ) and $FFFFFF;
- TranspColor32 := TColor( Color2RGBQuad( TranspColor ) );
- TmpMsk := NewDIBBitmap( fWidth, fHeight, pf1bit );
- TmpMsk.DIBPalEntries[ 1 ] := $FFFFFF;
- for Y := 0 to fHeight-1 do
- begin
- Src := ScanLine[ Y ];
- Dst := TmpMsk.ScanLine[ Y ];
- B := 0; C := 8;
- CASE PixelFormat OF
- pf4bit:
- begin
- W := 16;
- for i := 0 to 15 do
- if DIBPalEntries[ i ] = TranspColor32 then
- begin
- W := i; break;
- end;
- for X := 0 to (fWidth div 2)-1 do
- begin
- B := B shl 1;
- if Src^ shr 4 = W then inc( B );
- B := B shl 1;
- if Src^ and $0F = W then inc( B );
- Inc( Src );
- Dec( C, 2 );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- pf8bit:
- begin
- W := 256;
- for i := 0 to 255 do
- if DIBPalEntries[ i ] = TranspColor32 then
- begin
- W := i; break;
- end;
- for X := 0 to fWidth-1 do
- begin
- B := B shl 1;
- if Src^ = W then inc( B );
- Inc( Src );
- Dec( C );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- pf15bit:
- begin
- W := Color2Color15( TranspColor );
- for X := 0 to fWidth-1 do
- begin
- B := B shl 1;
- if PWord( Src )^ = W then inc( B );
- Inc( Src, 2 );
- Dec( C );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- pf16bit:
- begin
- W := Color2Color16( TranspColor );
- for X := 0 to fWidth-1 do
- begin
- B := B shl 1;
- if PWord( Src )^ = W then inc( B );
- Inc( Src, 2 );
- Dec( C );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- pf24bit:
- begin
- for X := 0 to fWidth-1 do
- begin
- B := B shl 1;
- if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
- Inc( Src, 3 );
- Dec( C );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- pf32bit:
- begin
- for X := 0 to fWidth-1 do
- begin
- B := B shl 1;
- if PInteger( Src )^ and $FFFFFF = TranspColor32 then inc( B );
- Inc( Src, 4 );
- Dec( C );
- if C = 0 then
- begin
- Dst^ := B;
- Inc( Dst );
- C := 8;
- end;
- end;
- end;
- END;
- if (C > 0) and (C < 8) then
- begin
- while C > 0 do
- begin
- B := B shl 1;
- dec( C );
- end;
- Dst^ := B;
- end;
- end;
- Assign( TmpMsk );
- TmpMsk.Free;
- end;
- {$ENDIF USE_OLDCONVERT2MASK} //Pascal
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.Invert]
- procedure TBitmap.Invert;
- var R: TRect;
- begin
- //BitBlt( Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, DSTINVERT )
- R := BoundsRect;
- InvertRect(Canvas.Handle, R);
- end;
-
- //[procedure TBitmap.DIBDrawRect]
- procedure TBitmap.DIBDrawRect( DC: HDC; X, Y: Integer; const R: TRect );
- begin
- if fDIBBits = nil then Exit;
- StretchDIBits( DC, X, Y, R.Right - R.Left, R.Bottom - R.Top,
- R.Left, fHeight - R.Bottom, R.Right - R.Left, R.Bottom - R.Top,
- fDIBBits, fDIBHeader^, DIB_RGB_COLORS, SRCCOPY );
- end;
-
- //[PROCEDURE _RotateBitmapMono]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmapMono( var DstBmp: PBitmap; SrcBmp: PBitmap );
- var X, Y, Z, Shf, Wbytes, BytesPerDstLine: Integer;
- Src, Dst, Dst1: PByte;
- Tmp: Byte;
- begin
-
- DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 7) and not 7, pf1bit );
- Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 2 * Sizeof( TRGBQuad ) );
-
- // Calculate ones:
- Dst := DstBmp.ScanLine[ 0 ];
- BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
- Wbytes := (SrcBmp.fWidth + 7) shr 3;
-
- Inc( Dst, (DstBmp.fWidth - 1) shr 3 );
- Shf := (DstBmp.fWidth - 1) and 7;
-
- // Rotating bits:
- for Y := 0 to SrcBmp.fHeight - 1 do
- begin
- Src := SrcBmp.ScanLine[ Y ];
- Dst1 := Dst;
- for X := Wbytes downto 1 do
- begin
- Tmp := Src^;
- Inc( Src );
- for Z := 8 downto 1 do
- begin
- Dst1^ := Dst1^ or ( (Tmp and $80) shr Shf );
- Tmp := Tmp shl 1;
- Inc( Dst1, BytesPerDstLine );
- end;
- end;
- Dec( Shf );
- if Shf < 0 then
- begin
- Shf := 7;
- Dec( Dst );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmapMono]
-
- //[PROCEDURE _RotateBitmap4bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmap4bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
- var X, Y, Shf, Wbytes, BytesPerDstLine: Integer;
- Src, Dst, Dst1: PByte;
- Tmp: Byte;
- begin
- DstBmp := NewDIBBitmap( SrcBmp.fHeight, (SrcBmp.fWidth + 1) and not 1, pf4bit );
- Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 16 * Sizeof( TRGBQuad ) );
-
- // Calculate ones:
- Dst := DstBmp.ScanLine[ 0 ];
- BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
- Wbytes := (SrcBmp.fWidth + 1) shr 1;
- Inc( Dst, (DstBmp.fWidth - 1) shr 1 );
- Shf := ((DstBmp.fWidth - 1) and 1) shl 2;
-
- // Rotating bits:
- for Y := 0 to SrcBmp.fHeight - 1 do
- begin
- Src := SrcBmp.ScanLine[ Y ];
- Dst1 := Dst;
- for X := Wbytes downto 1 do
- begin
- Tmp := Src^;
- Inc( Src );
- Dst1^ := Dst1^ or ( (Tmp and $F0) shr Shf );
- Inc( Dst1, BytesPerDstLine );
- Dst1^ := Dst1^ or ( ((Tmp shl 4) and $F0) shr Shf );
- Inc( Dst1, BytesPerDstLine );
- end;
- Dec( Shf, 4 );
- if Shf < 0 then
- begin
- Shf := 4;
- Dec( Dst );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmap4bit]
-
- //[PROCEDURE _RotateBitmap8bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmap8bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
- var X, Y, Wbytes, BytesPerDstLine: Integer;
- Src, Dst, Dst1: PByte;
- Tmp: Byte;
- begin
-
- DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
- Move( SrcBmp.fDIBHeader.bmiColors[ 0 ], DstBmp.fDIBHeader.bmiColors[ 0 ], 256 * Sizeof( TRGBQuad ) );
-
- // Calculate ones:
- Wbytes := SrcBmp.fWidth;
- Dst := DstBmp.ScanLine[ 0 ];
- BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
-
- Inc( Dst, DstBmp.fWidth - 1 );
-
- // Rotating bits:
- for Y := 0 to SrcBmp.fHeight - 1 do
- begin
- Src := SrcBmp.ScanLine[ Y ];
- Dst1 := Dst;
- for X := Wbytes downto 1 do
- begin
- Tmp := Src^;
- Inc( Src );
- Dst1^ := Tmp;
- Inc( Dst1, BytesPerDstLine );
- end;
- Dec( Dst );
- end;
-
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmap8bit]
-
- //[PROCEDURE _RotateBitmap16bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmap16bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
- var X, Y, Wwords, BytesPerDstLine: Integer;
- Src, Dst, Dst1: PWord;
- Tmp: Word;
- begin
- DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
- Wwords := SrcBmp.fWidth;
- Dst := DstBmp.ScanLine[ 0 ];
- BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
- Inc( Dst, DstBmp.fWidth - 1 );
-
- // Rotating bits:
- for Y := 0 to SrcBmp.fHeight - 1 do
- begin
- Src := SrcBmp.ScanLine[ Y ];
- Dst1 := Dst;
- for X := Wwords downto 1 do
- begin
- Tmp := Src^;
- Inc( Src );
- Dst1^ := Tmp;
- Inc( PByte(Dst1), BytesPerDstLine );
- end;
- Dec( Dst );
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmap16bit]
-
- //[PROCEDURE _RotateBitmap2432bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmap2432bit( var DstBmp: PBitmap; SrcBmp: PBitmap );
- var X, Y, Wwords, BytesPerDstLine, IncW: Integer;
- Src, Dst, Dst1: PDWord;
- Tmp: DWord;
- begin
-
- DstBmp := NewDIBBitmap( SrcBmp.fHeight, SrcBmp.fWidth, SrcBmp.PixelFormat );
-
- // Calculate ones:
- IncW := 4;
- if DstBmp.PixelFormat = pf24bit then
- IncW := 3;
- Wwords := SrcBmp.fWidth;
- Dst := DstBmp.ScanLine[ 0 ];
- BytesPerDstLine := cardinal( DstBmp.ScanLine[ 1 ]) - cardinal( Dst );
-
- Inc( PByte(Dst), (DstBmp.fWidth - 1) * IncW );
-
- // Rotating bits:
- for Y := 0 to SrcBmp.fHeight - 1 do
- begin
- Src := SrcBmp.ScanLine[ Y ];
- Dst1 := Dst;
- for X := Wwords downto 1 do
- begin
- Tmp := Src^ and $FFFFFF;
- Inc( PByte(Src), IncW );
- Dst1^ := Dst1^ or Tmp;
- Inc( PByte(Dst1), BytesPerDstLine );
- end;
- Dec( PByte(Dst), IncW );
- end;
-
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmap2432bit]
-
- type
- TRotateBmpRefs = {$ifndef wince}packed{$endif} record
- proc_RotateBitmapMono: procedure( var Dst: PBitmap; Src: PBitmap );
- proc_RotateBitmap4bit: procedure( var Dst: PBitmap; Src: PBitmap );
- proc_RotateBitmap8bit: procedure( var Dst: PBitmap; Src: PBitmap );
- proc_RotateBitmap16bit: procedure( var Dst: PBitmap; Src: PBitmap );
- proc_RotateBitmap2432bit: procedure( var Dst: PBitmap; Src: PBitmap );
- end;
-
- var
- RotateProcs: TRotateBmpRefs;
-
- //[PROCEDURE _RotateBitmapRight]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _RotateBitmapRight( SrcBmp: PBitmap );
- var DstBmp: PBitmap;
- RotateProc: procedure( var DstBmp: PBitmap; SrcBmp: PBitmap );
- begin
- if SrcBmp.fHandleType <> bmDIB then Exit;
-
- case SrcBmp.PixelFormat of
- pf1bit: RotateProc := RotateProcs.proc_RotateBitmapMono;
- pf4bit: RotateProc := RotateProcs.proc_RotateBitmap4bit;
- pf8bit: RotateProc := RotateProcs.proc_RotateBitmap8bit;
- pf15bit, pf16bit: RotateProc := RotateProcs.proc_RotateBitmap16bit;
- else RotateProc := RotateProcs.proc_RotateBitmap2432bit;
- end;
-
- if not Assigned( RotateProc ) then Exit;
- RotateProc( DstBmp, SrcBmp );
-
- if DstBmp.fHeight > SrcBmp.fWidth then
- begin
- DstBmp.fDIBSize := DstBmp.fScanLineSize * SrcBmp.fWidth;
- if DstBmp.fDIBHeader.bmiHeader.biHeight > 0 then
- Move( DstBmp.ScanLine[ SrcBmp.fWidth - 1 ]^, DstBmp.ScanLine[ DstBmp.fHeight - 1 ]^,
- DstBmp.fDIBSize );
- DstBmp.fHeight := SrcBmp.fWidth;
- DstBmp.fDIBHeader.bmiHeader.biHeight := DstBmp.fHeight;
- end;
-
- SrcBmp.ClearData;
-
- SrcBmp.fDIBHeader := DstBmp.fDIBHeader;
- DstBmp.fDIBHeader := nil;
-
- SrcBmp.fDIBBits := DstBmp.fDIBBits;
- DstBmp.fDIBBits := nil;
- SrcBmp.fDIBAutoFree := DstBmp.fDIBAutoFree;
-
- SrcBmp.fDIBSize := DstBmp.fDIBSize;
-
- SrcBmp.fWidth := DstBmp.fWidth;
- SrcBmp.fHeight := DstBmp.fHeight;
- DstBmp.Free;
- end;
- {$ENDIF ASM_VERSION}
- //[END _RotateBitmapRight]
-
- //[procedure TBitmap.RotateRight]
- procedure TBitmap.RotateRight;
- const AllRotators: TRotateBmpRefs = (
- proc_RotateBitmapMono: _RotateBitmapMono;
- proc_RotateBitmap4bit: _RotateBitmap4bit;
- proc_RotateBitmap8bit: _RotateBitmap8bit;
- proc_RotateBitmap16bit: _RotateBitmap16bit;
- proc_RotateBitmap2432bit: _RotateBitmap2432bit );
- begin
- RotateProcs := AllRotators;
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure _RotateBitmapLeft]
- procedure _RotateBitmapLeft( Src: PBitmap );
- begin
- _RotateBitmapRight( Src );
- _RotateBitmapRight( Src );
- _RotateBitmapRight( Src );
- end;
-
- //[procedure TBitmap.RotateLeft]
- procedure TBitmap.RotateLeft;
- begin
- RotateRight;
- _RotateBitmapRight( @Self );
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure TBitmap.RotateLeftMono]
- procedure TBitmap.RotateLeftMono;
- begin
- if PixelFormat <> pf1bit then Exit;
- RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure TBitmap.RotateRightMono]
- procedure TBitmap.RotateRightMono;
- begin
- if PixelFormat <> pf1bit then Exit;
- RotateProcs.proc_RotateBitmapMono := _RotateBitmapMono;
- _RotateBitmapLeft( @Self );
- end;
-
- //[procedure TBitmap.RotateLeft16bit]
- procedure TBitmap.RotateLeft16bit;
- begin
- if PixelFormat <> pf16bit then Exit;
- RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
- _RotateBitmapLeft( @Self );
- end;
-
- //[procedure TBitmap.RotateLeft4bit]
- procedure TBitmap.RotateLeft4bit;
- begin
- if PixelFormat <> pf4bit then Exit;
- RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
- _RotateBitmapLeft( @Self );
- end;
-
- //[procedure TBitmap.RotateLeft8bit]
- procedure TBitmap.RotateLeft8bit;
- begin
- if PixelFormat <> pf8bit then Exit;
- RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
- _RotateBitmapLeft( @Self );
- end;
-
- //[procedure TBitmap.RotateLeftTrueColor]
- procedure TBitmap.RotateLeftTrueColor;
- begin
- if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;
- RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
- _RotateBitmapLeft( @Self );
- end;
-
- //[procedure TBitmap.RotateRight16bit]
- procedure TBitmap.RotateRight16bit;
- begin
- if PixelFormat <> pf16bit then Exit;
- RotateProcs.proc_RotateBitmap16bit := _RotateBitmap16bit;
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure TBitmap.RotateRight4bit]
- procedure TBitmap.RotateRight4bit;
- begin
- if PixelFormat <> pf4bit then Exit;
- RotateProcs.proc_RotateBitmap4bit := _RotateBitmap4bit;
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure TBitmap.RotateRight8bit]
- procedure TBitmap.RotateRight8bit;
- begin
- if PixelFormat <> pf8bit then Exit;
- RotateProcs.proc_RotateBitmap8bit := _RotateBitmap8bit;
- _RotateBitmapRight( @Self );
- end;
-
- //[procedure TBitmap.RotateRightTrueColor]
- procedure TBitmap.RotateRightTrueColor;
- begin
- if not (PixelFormat in [ pf24bit, pf32bit ]) then Exit;
- RotateProcs.proc_RotateBitmap2432bit := _RotateBitmap2432bit;
- _RotateBitmapRight( @Self );
- end;
-
- //[function TBitmap.GetPixels]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetPixels(X, Y: Integer): TColor;
- var DC: HDC;
- Save: THandle;
- begin
- Result := clNone;
- //if GetHandle = 0 then Exit;
- if Empty then Exit;
- fDetachCanvas( @Self );
- DC := CreateCompatibleDC( 0 );
- Save := SelectObject( DC, GetHandle );
- ASSERT( Save <> 0, 'Can not select bitmap to DC' );
- Result := Windows.GetPixel( DC, X, Y );
- SelectObject( DC, Save );
- DeleteDC( DC );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.SetPixels]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetPixels(X, Y: Integer; const Value: TColor);
- var DC: HDC;
- Save: THandle;
- begin
- //if GetHandle = 0 then Exit;
- if Empty then Exit;
- fDetachCanvas( @Self );
- DC := CreateCompatibleDC( 0 );
- Save := SelectObject( DC, GetHandle );
- ASSERT( Save <> 0, 'Can not select bitmap to DC' );
- Windows.SetPixel( DC, X, Y, Color2RGB( Value ) );
- SelectObject( DC, Save );
- DeleteDC( DC );
- end;
- {$ENDIF ASM_VERSION}
-
- //[FUNCTION _GetDIBPixelsPalIdx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function _GetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer ): TColor;
- var Pixel: Byte;
- begin
- Pixel := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
- + (X div (Bmp.fPixelsPerByteMask + 1))) )^;
- Pixel := ( Pixel shr ( (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
- * Bmp.fDIBHeader.bmiHeader.biBitCount ) )
- and Bmp.fPixelMask;
- Result := TColor( Color2RGBQuad( TColor( PRGBQuad( DWORD(@Bmp.fDIBHeader.bmiColors[ 0 ])
- + DWORD(Pixel) * Sizeof( TRGBQuad ) )^ ) ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END _GetDIBPixelsPalIdx]
-
- //[FUNCTION _GetDIBPixels16bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function _GetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer ): TColor;
- var Pixel: Word;
- begin
- Pixel := PWord( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X * 2) )^;
- if Bmp.fPixelMask = 15 then
- Result := (Pixel shr 7) and $F8 or (Pixel shl 6) and $F800
- or (Pixel shl 19) and $F80000
- else
- Result := (Pixel shr 8) and $F8 or (Pixel shl 5) and $FC00
- or (Pixel shl 19) and $F80000;
- end;
- {$ENDIF ASM_VERSION}
- //[END _GetDIBPixels16bit]
-
- //[FUNCTION _GetDIBPixelsTrueColor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function _GetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer ): TColor;
- var Pixel: DWORD;
- begin
- Pixel := PDWORD( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta +
- X * Bmp.fBytesPerPixel) )^ and $FFFFFF;
- Result := TColor( Color2RGBQuad( TColor( Pixel ) ) );
- end;
- {$ENDIF ASM_VERSION}
- //[END _GetDIBPixelsTrueColor]
-
- //[function TBitmap.GetDIBPixels]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TBitmap.GetDIBPixels(X, Y: Integer): TColor;
- begin
- if not Assigned( fGetDIBPixels ) then
- begin
- if fHandleType = bmDIB then
- begin
- fScanLine0 := ScanLine[ 0 ];
- fScanLineDelta := cardinal(ScanLine[ 1 ]) - cardinal(fScanLine0);
- case PixelFormat of
- pf1bit:
- begin
- fPixelMask := $01;
- fPixelsPerByteMask := 7;
- fGetDIBPixels := _GetDIBPixelsPalIdx;
- end;
- pf4bit:
- begin
- fPixelMask := $0F;
- fPixelsPerByteMask := 1;
- fGetDIBPixels := _GetDIBPixelsPalIdx;
- end;
- pf8bit:
- begin
- fPixelMask := $FF;
- fPixelsPerByteMask := 0;
- fGetDIBPixels := _GetDIBPixelsPalIdx;
- end;
- pf15bit:
- begin
- fPixelMask := 15;
- fGetDIBPixels := _GetDIBPixels16bit;
- end;
- pf16bit:
- begin
- fPixelMask := 16;
- fGetDIBPixels := _GetDIBPixels16bit;
- end;
- pf24bit:
- begin
- fPixelsPerByteMask := 0;
- fBytesPerPixel := 3;
- fGetDIBPixels := _GetDIBPixelsTrueColor;
- end;
- pf32bit:
- begin
- fPixelsPerByteMask := 1;
- fBytesPerPixel := 4;
- fGetDIBPixels := _GetDIBPixelsTrueColor;
- end;
- else;
- end;
- end;
- if not Assigned( fGetDIBPixels ) then
- begin
- Result := Pixels[ X, Y ];
- Exit;
- end;
- end;
- Result := fGetDIBPixels( @Self, X, Y );
- end;
- {$ENDIF ASM_VERSION}
-
- //[PROCEDURE _SetDIBPixels1bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _SetDIBPixels1bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
- var Pixel: Byte;
- Pos: PByte;
- Shf: Integer;
- begin
- Value := Color2RGB( Value );
- if ((Value shr 16) and $FF) + ((Value shr 8) and $FF) + (Value and $FF)
- < 255 * 3 div 2 then Pixel := 0 else Pixel := $80;
- Pos := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X div 8) );
- Shf := X and 7;
- Pos^ := Pos^ and ($FF7F shr Shf) or (Pixel shr Shf);
- end;
- {$ENDIF ASM_VERSION}
- //[END _SetDIBPixels1bit]
-
- //[PROCEDURE _SetDIBPixelsPalIdx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _SetDIBPixelsPalIdx( Bmp: PBitmap; X, Y: Integer; Value: TColor );
- var Pixel: Byte;
- Pos: PByte;
- Shf: Integer;
- begin
- Pixel := Bmp.DIBPalNearestEntry( Value );
- Pos := PByte( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
- + X div (Bmp.fPixelsPerByteMask + 1)) );
- Shf := (Bmp.fPixelsPerByteMask - (X and Bmp.fPixelsPerByteMask))
- * Bmp.fDIBHeader.bmiHeader.biBitCount;
- Pos^ := Pos^ and not (Bmp.fPixelMask shl Shf) or (Pixel shl Shf);
- end;
- {$ENDIF ASM_VERSION}
- //[END _SetDIBPixelsPalIdx]
-
- //[PROCEDURE _SetDIBPixels16bit]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _SetDIBPixels16bit( Bmp: PBitmap; X, Y: Integer; Value: TColor );
- var RGB16: Word;
- Pos: PWord;
- begin
- Value := Color2RGB( Value );
- if Bmp.fPixelMask = 15 then
- RGB16 := (Value shr 19) and $001F or (Value shr 6) and $03E0
- or (Value shl 7) and $7C00
- else
- RGB16 := (Value shr 19) and $001F or (Value shr 5) and $07E0
- or (Value shl 8) and $F800;
- Pos := PWord( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta + X * 2) );
- Pos^ := RGB16;
- end;
- {$ENDIF ASM_VERSION}
- //[END _SetDIBPixels16bit]
-
- //[PROCEDURE _SetDIBPixelsTrueColor]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure _SetDIBPixelsTrueColor( Bmp: PBitmap; X, Y: Integer; Value: TColor );
- var RGB: TRGBQuad;
- Pos: PDWord;
- begin
- RGB := Color2RGBQuad( Value );
- Pos := PDWORD( cardinal(Bmp.fScanLine0) + cardinal(Y * Bmp.fScanLineDelta
- + X * Bmp.fBytesPerPixel) );
- Pos^ := Pos^ and $FF000000 or DWORD(RGB);
- end;
- {$ENDIF ASM_VERSION}
- //[END _SetDIBPixelsTrueColor]
-
- //[procedure TBitmap.SetDIBPixels]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.SetDIBPixels(X, Y: Integer; const Value: TColor);
- begin
- if not Assigned( fSetDIBPixels ) then
- begin
- if fHandleType = bmDIB then
- begin
- fScanLine0 := ScanLine[ 0 ];
- fScanLineDelta := cardinal(ScanLine[ 1 ]) - cardinal(fScanLine0);
- case PixelFormat of
- pf1bit:
- begin
- //fPixelMask := $01;
- //fPixelsPerByteMask := 7;
- fSetDIBPixels := _SetDIBPixels1bit;
- end;
- pf4bit:
- begin
- fPixelMask := $0F;
- fPixelsPerByteMask := 1;
- fSetDIBPixels := _SetDIBPixelsPalIdx;
- end;
- pf8bit:
- begin
- fPixelMask := $FF;
- fPixelsPerByteMask := 0;
- fSetDIBPixels := _SetDIBPixelsPalIdx;
- end;
- pf15bit:
- begin
- fPixelMask := 15;
- fSetDIBPixels := _SetDIBPixels16bit;
- end;
- pf16bit:
- begin
- fPixelMask := 16;
- fSetDIBPixels := _SetDIBPixels16bit;
- end;
- pf24bit:
- begin
- fPixelsPerByteMask := 0;
- fBytesPerPixel := 3;
- fSetDIBPixels := _SetDIBPixelsTrueColor;
- end;
- pf32bit:
- begin
- fPixelsPerByteMask := 1;
- fBytesPerPixel := 4;
- fSetDIBPixels := _SetDIBPixelsTrueColor;
- end;
- else;
- end;
- end;
- if not Assigned( fSetDIBPixels ) then
- begin
- Pixels[ X, Y ] := Value;
- Exit;
- end;
- end;
- fSetDIBPixels( @Self, X, Y, Value );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.FlipVertical]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.FlipVertical;
- var DC: HDC;
- Save: THandle;
- TmpScan: PByte;
- Y: Integer;
- begin
- if fHandle <> 0 then
- begin
- fDetachCanvas( @Self );
- DC := CreateCompatibleDC( 0 );
- Save := SelectObject( DC, fHandle );
- StretchBlt( DC, 0, fHeight - 1, fWidth, -fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
- SelectObject( DC, Save );
- DeleteDC( DC );
- end
- else
- if fDIBBits <> nil then
- begin
- GetMem( TmpScan, ScanLineSize );
- for Y := 0 to fHeight div 2 do
- begin
- Move( ScanLine[ Y ]^, TmpScan^, fScanLineSize );
- Move( ScanLine[ fHeight - Y - 1 ]^, ScanLine[ Y ]^, fScanLineSize );
- Move( TmpScan^, ScanLine[ fHeight - Y - 1 ]^, fScanLineSize );
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.FlipHorizontal]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.FlipHorizontal;
- var DC: HDC;
- Save: THandle;
- begin
- if GetHandle <> 0 then
- begin
- fDetachCanvas( @Self );
- DC := CreateCompatibleDC( 0 );
- Save := SelectObject( DC, fHandle );
- StretchBlt( DC, fWidth - 1, 0, -fWidth, fHeight, DC, 0, 0, fWidth, fHeight, SRCCOPY );
- SelectObject( DC, Save );
- DeleteDC( DC );
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TBitmap.CopyRect]
- {$IFDEF ASM_VERSION}
- procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
- const SrcRect: TRect);
- asm
- PUSHAD
- MOV EBX, EAX
- MOV ESI, ECX
- MOV EDI, EDX
- CALL GetHandle
- TEST EAX, EAX
- JZ @@exit
- MOV EAX, ESI
- CALL GetHandle
- TEST EAX, EAX
- JZ @@exit
- CALL StartDC
- XCHG EBX, ESI
- CMP EBX, ESI
- JNZ @@diff1
- PUSH EAX
- PUSH 0
- JMP @@nodiff1
- @@diff1:
- CALL StartDC
- @@nodiff1:
- PUSH SrcCopy // ->
- MOV EBP, [SrcRect]
- MOV EAX, [EBP].TRect.Bottom
- MOV EDX, [EBP].TRect.Top
- SUB EAX, EDX
- PUSH EAX // ->
- MOV EAX, [EBP].TRect.Right
- MOV ECX, [EBP].TRect.Left
- SUB EAX, ECX
- PUSH EAX // ->
- PUSH EDX // ->
- PUSH ECX // ->
- PUSH dword ptr [ESP+24] // -> DCsrc
- MOV EAX, [EDI].TRect.Bottom
- MOV EDX, [EDI].TRect.Top
- SUB EAX, EDX
- PUSH EAX // ->
- MOV EAX, [EDI].TRect.Right
- MOV ECX, [EDI].TRect.Left
- SUB EAX, ECX
- PUSH EAX // ->
- PUSH EDX // ->
- PUSH ECX // ->
- PUSH dword ptr [ESP+13*4] // -> DCdst
- CALL StretchBlt
- CMP EBX, ESI
- JNE @@diff2
- POP ECX
- POP ECX
- JMP @@nodiff2
- @@diff2:
- CALL FinishDC
- @@nodiff2:
- CALL FinishDC
- @@exit:
- POPAD
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TBitmap.CopyRect(const DstRect: TRect; SrcBmp: PBitmap;
- const SrcRect: TRect);
- var DCsrc, DCdst: HDC;
- SaveSrc, SaveDst: THandle;
- begin
- if (GetHandle = 0) or (SrcBmp.GetHandle = 0) then Exit;
- fDetachCanvas( @Self );
- SrcBmp.fDetachCanvas( SrcBmp );
- DCsrc := CreateCompatibleDC( 0 );
- SaveSrc := SelectObject( DCsrc, SrcBmp.fHandle );
- DCdst := DCsrc;
- SaveDst := 0;
- if SrcBmp <> @Self then
- begin
- DCdst := CreateCompatibleDC( 0 );
- SaveDst := SelectObject( DCdst, fHandle );
- end;
- StretchBlt( DCdst, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
- DstRect.Bottom - DstRect.Top, DCsrc, SrcRect.Left, SrcRect.Top,
- SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
- SRCCOPY );
- if SrcBmp <> @Self then
- begin
- SelectObject( DCdst, SaveDst );
- DeleteDC( DCdst );
- end;
- SelectObject( DCsrc, SaveSrc );
- DeleteDC( DCsrc );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBitmap.CopyToClipboard]
- function TBitmap.CopyToClipboard: Boolean;
- var DibMem: PChar;
- HdrSize: Integer;
- Gbl: HGlobal;
- //Mem: PStream;
- //Sz: Integer;
- //Pt: Pointer;
- Restore_Compression: Integer;
- begin
- Result := FALSE;
- if Applet = nil then Exit;
- if not OpenClipboard( Applet.GetWindowHandle ) then
- Exit;
- if EmptyClipboard then
- begin
- HandleType := bmDIB;
- HdrSize := sizeof( TBitmapInfoHeader );
- Restore_Compression := -1;
- TRY
- if fDIBHeader.bmiHeader.biBitCount <= 8 then
- Inc( HdrSize,
- (1 shl fDIBHeader.bmiHeader.biBitCount) * Sizeof( TRGBQuad ) )
- else
- begin
- if fDIBHeader.bmiHeader.biCompression = BI_RGB then
- begin
- CASE fDIBHeader.bmiHeader.biBitCount OF
- {24,} 32:
- begin
- Restore_Compression := fDIBHeader.bmiHeader.biCompression;
- fDIBHeader.bmiHeader.biCompression := BI_BITFIELDS;
- PDWORD( @ fDIBHeader.bmiColors[ 0 ] )^ := $FF0000;
- PDWORD( cardinal( @ fDIBHeader.bmiColors[ 0 ] ) + 4 )^ := $FF00;
- PDWORD( cardinal( @ fDIBHeader.bmiColors[ 0 ] ) + 8 )^ := $FF;
- Inc( HdrSize, 12 );
- end;
- END;
- end;
- end;
- Gbl := GlobalAlloc( GMEM_MOVEABLE, HdrSize + fDIBSize );
- DibMem := GlobalLock( Gbl );
- if DibMem <> nil then
- begin
- Move( fDIBHeader^, DibMem^, HdrSize );
- Move( fDIBBits^, Pointer( cardinal( DibMem ) + cardinal(HdrSize) )^, fDIBSize );
- if not GlobalUnlock( Gbl ) and (GetLastError = NO_ERROR) then
- begin
- Result := SetClipboardData( CF_DIB, Gbl ) <> 0;
- end;
- end;
- FINALLY
- if Restore_Compression >= 0 then
- fDIBHeader.bmiHeader.biCompression := Restore_Compression;
- END;
-
- end;
- CloseClipboard;
- end;
-
- //[function TBitmap.PasteFromClipboard]
- function TBitmap.PasteFromClipboard: Boolean;
- var Gbl: HGlobal;
- //DIBPtr: PChar;
- Size {, HdrSize}: Integer;
- Mem: PChar;
- Strm: PStream;
- begin
- Result := FALSE;
- if Applet = nil then Exit;
- if not OpenClipboard( Applet.GetWindowHandle ) then Exit;
- TRY
- if IsClipboardFormatAvailable( CF_DIB ) then
- begin
- Gbl := GetClipboardData( CF_DIB );
- if Gbl <> 0 then
- begin
- Size := GlobalSize( Gbl );
- Mem := GlobalLock( Gbl );
- TRY
- if (Size > 0) and (Mem <> nil) then
- begin
- Strm := NewMemoryStream;
- Strm.Write( Mem^, Size );
- Strm.Position := 0;
- LoadFromStreamEx( Strm );
- ////Strm.SaveToFile( GetStartDir + 'test_paste.bmp', 0, Strm.Size );
- Strm.Free;
- Result := not Empty;
- end;
- FINALLY
- GlobalUnlock( Gbl );
- END;
- end;
- end;
- FINALLY
- CloseClipboard;
- END;
- end;
-
- ///////////////////////////////////////////////////////////////////////
- // I C O N
- ///////////////////////////////////////////////////////////////////////
-
- { -- icon -- }
-
- //[function NewIcon]
- function NewIcon: PIcon;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := TIcon.Create;*){--}
- {$IFDEF ICON_DIFF_WH}
- Result.FWidth := 32;
- Result.FHeight := 32;
- {$ELSE}
- Result.FSize := 32;
- {$ENDIF}
- end;
-
- { TIcon }
-
- //[PROCEDURE asmIconEmpty]
- {$IFDEF ASM_VERSION}
- {$ENDIF ASM_VERSION}
- //[END asmIconEmpty]
-
- //[procedure TIcon.Clear]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.Clear;
- begin
- if fHandle <> 0 then
- begin
- if not FShareIcon then
- DestroyIcon( fHandle );
- fHandle := 0;
- end;
- fShareIcon := False;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_LOCAL}
- {$UNDEF ASM_LOCAL}
- {$ENDIF}
-
- {$IFNDEF ICON_DIFF_WH}
- {$IFDEF ASM_VERSION} {$DEFINE ASM_LOCAL} {$ENDIF}
- {$ENDIF}
-
- //[function TIcon.Convert2Bitmap]
- {$IFDEF ASM_LOCAL}
- {$ELSE ASM_VERSION} //Pascal
- function TIcon.Convert2Bitmap(TranColor: TColor): HBitmap;
- var DC0, DC2: HDC;
- Save: THandle;
- Br: HBrush;
- begin
- Result := 0;
- if Empty then Exit;
- DC0 := GetDC( 0 );
- DC2 := CreateCompatibleDC( DC0 );
- {$IFDEF ICON_DIFF_WH}
- Result := CreateCompatibleBitmap( DC0, fWidth, fHeight );
- {$ELSE}
- Result := CreateCompatibleBitmap( DC0, fSize, fSize );
- {$ENDIF}
- Save := SelectObject( DC2, Result );
- Br := CreateSolidBrush( Color2RGB( TranColor ) );
- {$IFDEF ICON_DIFF_WH}
- FillRect( DC2, MakeRect( 0, 0, fWidth, fHeight ), Br );
- {$ELSE}
- FillRect( DC2, MakeRect( 0, 0, fSize, fSize ), Br );
- {$ENDIF}
- DeleteObject( Br );
- Draw( DC2, 0, 0 );
- SelectObject( DC2, Save );
- DeleteDC( DC2 );
- ReleaseDC( 0, DC0 );
- end;
- {$ENDIF ASM_VERSION}
-
- //[destructor TIcon.Destroy]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- destructor TIcon.Destroy;
- begin
- Clear;
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TIcon.Draw]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.Draw(DC: HDC; X, Y: Integer);
- begin
- if Empty then Exit;
- {$IFDEF ICON_DIFF_WH}
- DrawIconEx( DC, X, Y, fHandle, fWidth, fHeight, 0, 0, DI_NORMAL );
- {$ELSE}
- DrawIconEx( DC, X, Y, fHandle, fSize, fSize, 0, 0, DI_NORMAL );
- {$ENDIF}
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TIcon.StretchDraw]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.StretchDraw(DC: HDC; Dest: TRect);
- begin
- if Empty then Exit;
- DrawIconEx( DC, Dest.Left, Dest.Top, FHandle, Dest.Right - Dest.Left,
- Dest.Bottom - Dest.Top, 0, 0, DI_NORMAL );
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TIcon.GetEmpty]
- function TIcon.GetEmpty: Boolean;
- begin
- Result := (fHandle = 0)
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- and ((ImgBmp = nil) or ImgBmp.Empty)
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- ;
- end;
-
- //*
- //[function TIcon.GetHotSpot]
- function TIcon.GetHotSpot: TPoint;
- {$ifdef win32}
- var II : TIconInfo;
- {$endif win32}
- begin
- Result := MakePoint( 0, 0 );
- {$ifdef win32}
- if FHandle = 0 then Exit;
- GetIconInfo( FHandle, II );
- Result.x := II.xHotspot;
- Result.y := II.yHotspot;
- if II.hbmMask <> 0 then
- DeleteObject( II.hbmMask );
- if II.hbmColor <> 0 then
- DeleteObject( II.hbmColor );
- {$endif win32}
- end;
-
- //*
- //[procedure TIcon.LoadFromFile]
- procedure TIcon.LoadFromFile(const FileName: KOLString);
- var Strm : PStream;
- begin
- Strm := NewReadFileStream( Filename );
- LoadFromStream( Strm );
- Strm.Free;
- end;
-
- //*
- //[procedure TIcon.LoadFromStream]
- procedure TIcon.LoadFromStream(Strm: PStream);
- var DesiredSize : Integer;
- Pos : DWord;
- Mem : PStream;
- {$IFNDEF ICONLOAD_PRESERVEBMPS}
- ImgBmp, MskBmp : PBitmap;
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- TmpBmp: PBitmap;
- function ReadIcon : Boolean;
- var IH : TIconHeader;
- IDI, FoundIDI : TIconDirEntry;
- I, J, SumSz, FoundSz, D : Integer;
- II : TIconInfo;
- BIH : TBitmapInfoheader;
- SzImg: DWORD;
- begin
- Result := False;
- if Strm.Read( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;
- if (IH.idReserved = Sizeof( TBitmapInfoHeader )) then
- begin
- Strm.Position := Strm.Position - Sizeof( IH );
- {$IFDEF ICON_DIFF_WH} fWidth := 0;
- fHeight := 0;
- {$ELSE} fSize := 0;
- {$ENDIF}
- SumSz := 0;
- end
- else
- if (IH.idReserved = 0) and ((IH.idType = 1) or (IH.idType = 2)) and
- (IH.idCount >= 1) then
- begin
-
- if (IH.idReserved <> 0) or ((IH.idType <> 1) and (IH.idType <> 2)) or
- (IH.idCount < 1) or (IH.idCount >= 1024) then Exit;
- SumSz := Sizeof( IH );
- FoundSz := 1000000;
- for I := 1 to IH.idCount do
- begin
- if Strm.Read( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;
- Inc( SumSz, IDI.dwBytesInRes + Sizeof( IDI ) );
- D := IDI.bWidth - DesiredSize;
- if D < 0 then D := -D;
- if D < FoundSz then
- begin
- FoundSz := D;
- FoundIDI := IDI;
- end;
- end;
- if FoundSz = 1000000 then Exit;
- Strm.Position := Integer( Pos ) + FoundIDI.dwImageOffset;
- {$IFDEF ICON_DIFF_WH} fWidth := FoundIDI.bWidth;
- fHeight := FoundIDI.bHeight;
- {$ELSE} fSize := FoundIDI.bWidth;
- {$ENDIF}
-
- end
- else Exit;
-
- if Strm.Read( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;
-
- {$IFDEF ICON_DIFF_WH}
- fWidth := BIH.biWidth;
- BIH.biHeight := BIH.biHeight div 2; // fSize;
- fHeight := BIH.biHeight;
- {$ELSE}
- fSize := BIH.biWidth;
- BIH.biHeight := BIH.biHeight div 2; // fSize;
- {$ENDIF}
-
- Mem := NewMemoryStream;
- if (FoundIDI.bColorCount >= 2) or (FoundIDI.bReserved = 1) or
- (FoundIDI.bColorCount = 0) then
- begin
- I := 0;
- SzImg := ((BIH.biBitCount * BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
- if (BIH.biSizeImage > 0) and (SzImg > BIH.biSizeImage) then
- SzImg := BIH.biSizeImage;
- if BIH.biBitCount <= 8 then
- begin
- I := (1 shl BIH.biBitCount) * Sizeof( TRGBQuad );
- end;
- Mem.Write( BIH, Sizeof( BIH ) );
- if I > 0 then
- begin
- if Stream2Stream( Mem, Strm, I ) <> DWORD(I) then Exit;
- end
- else
- if BIH.biBitCount = 16 then
- begin
- for I := 0 to 2 do
- begin
- J := InitColors[ I ];
- Mem.Write( J, 4 );
- end;
- end;
- I := Stream2Stream( Mem, Strm, SzImg );
- if I <> Integer( SzImg ) then Exit;
- {$IFDEF ICON_DIFF_WH}
- ImgBmp := NewBitmap( fWidth, fHeight );
- {$ELSE}
- ImgBmp := NewBitmap( fSize, fSize );
- {$ENDIF}
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- Add2AutoFree( ImgBmp );
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- Mem.Seek( 0, spBegin );
- {$IFDEF LOADEX}
- ImgBmp.LoadFromStreamEx( Mem );
- {$ELSE}
- ImgBmp.LoadFromStream( Mem );
- {$ENDIF}
- if ImgBmp.Empty then Exit;
- end
- else
- begin
- Mem.Write( BIH, Sizeof( BIH ) );
- end;
-
- BIH.biBitCount := 1;
- BIH.biPlanes := 1;
- BIH.biClrUsed := 0;
- Mem.Seek( 0, spBegin );
- BIH.biSizeImage := ((BIH.biWidth + 31) div 32) * 4 * BIH.biHeight;
- Mem.Write( BIH, Sizeof( BIH ) );
- I := 0;
- Mem.Write( I, Sizeof( I ) );
- I := $FFFFFF;
- Mem.Write( I, Sizeof( I ) );
- I := BIH.biSizeImage;
- J := Stream2Stream( Mem, Strm, I );
- while J < I do
- begin
- D := 0;
- Mem.Write( D, 4 );
- Inc( J, 4 );
- end;
-
- {$IFDEF ICON_DIFF_WH}
- MskBmp := NewBitmap( fWidth, fHeight );
- {$ELSE}
- MskBmp := NewBitmap( fSize, fSize );
- {$ENDIF}
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- Add2AutoFree( MskBmp );
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- Mem.Seek( 0, spBegin );
- {$IFDEF LOADEX}
- MskBmp.LoadFromStreamEx( Mem );
- {$ELSE}
- MskBmp.LoadFromStream( Mem );
- {$ENDIF}
-
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- Result := TRUE;
- if not Only_Bmp then
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- begin
- II.fIcon := True;
- II.xHotspot := 0;
- II.yHotspot := 0;
- II.hbmMask := 0;
- if Assigned( MskBmp ) and not MskBmp.Empty then
- II.hbmMask := MskBmp.Handle;
- II.hbmColor := 0;
- if ImgBmp <> nil then
- II.hbmColor := ImgBmp.Handle;
- fHandle := CreateIconIndirect( II );
- if SumSz > 0 then
- Strm.Seek( Integer( Pos ) + SumSz, spBegin );
- Result := fHandle <> 0;
- end;
-
- end;
- begin
- DesiredSize := Size;
- if DesiredSize = 0 then
- DesiredSize := GetSystemMetrics( SM_CXICON );
- Clear;
- Pos := Strm.Position;
-
- Mem := nil;
- {$IFDEF ICONLOAD_PRESERVEBMPS}
- if ImgBmp <> nil then
- begin
- RemoveFromAutoFree( ImgBmp );
- RemoveFromAutoFree( MskBmp );
- Free_And_Nil( ImgBmp );
- Free_And_Nil( MskBmp );
- end;
- {$ELSE}
- ImgBmp := nil;
- MskBmp := nil;
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- TmpBmp := nil;
-
- if not ReadIcon then
- begin
- Clear;
- Strm.Seek( Pos, spBegin );
- end;
-
- Mem.Free;
- {$IFNDEF ICONLOAD_PRESERVEBMPS}
- ImgBmp.Free;
- MskBmp.Free;
- {$ENDIF ICONLOAD_PRESERVEBMPS}
- TmpBmp.Free;
- end;
-
- {$ifdef win32}
- //[procedure TIcon.SaveToFile]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.SaveToFile(const FileName: KOLString);
- begin
- SaveIcons2File( [ @Self ], FileName );
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TIcon.SaveToStream]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.SaveToStream(Strm: PStream);
- begin
- SaveIcons2Stream( [ @Self ], Strm );
- end;
- {$ENDIF ASM_VERSION}
- {$endif win32}
-
- {$IFDEF ASM_noVERSION}
- //[procedure TIcon.SetHandle]
- procedure TIcon.SetHandle(const Value: HIcon);
- const szII = sizeof( TIconInfo );
- szBIH = sizeof(TBitmapInfoHeader);
- asm //cmd //opd
- CMP EDX, [EAX].fHandle
- JE @@exit
- PUSHAD
- PUSH EDX
- MOV EBX, EAX
- CALL Clear
- POP ECX
- MOV [EBX].fHandle, ECX
- JECXZ @@fin
- ADD ESP, -szBIH
- PUSH ESP
- PUSH ECX
- CALL GetIconInfo
- MOV ESI, [ESP].TIconInfo.hbmMask
- MOV EDI, [ESP].TIconInfo.hbmColor
- PUSH ESP
- PUSH szBIH
- PUSH ESI
- CALL GetObject
- POP EAX
- POP [EBX].fSize
- ADD ESP, szBIH-8
- TEST ESI, ESI
- JZ @@1
- PUSH ESI
- CALL DeleteObject
- @@1: TEST EDI, EDI
- JZ @@fin
- PUSH EDI
- CALL DeleteObject
- @@fin: POPAD
- @@exit:
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TIcon.SetHandle(const Value: HIcon);
- {$ifdef win32}
- var II : TIconInfo;
- B: TagBitmap;
- {$endif win32}
- begin
- if FHandle = Value then Exit;
- Clear;
- FHandle := Value;
- if Value <> 0 then
- begin
- {$ifdef wince}
- {$IFDEF ICON_DIFF_WH}
- fWidth := 32;
- fHeight := 32;
- {$ELSE}
- fSize := 32;
- {$ENDIF}
- {$else}
- GetIconInfo( FHandle, II );
- GetObject( II.hbmMask, Sizeof( B ), @B );
- {$IFDEF ICON_DIFF_WH}
- fWidth := B.bmWidth;
- fHeight := B.bmHeight;
- {$ELSE}
- fSize := B.bmWidth;
- {$ENDIF}
- if II.hbmMask <> 0 then
- DeleteObject( II.hbmMask );
- if II.hbmColor <> 0 then
- DeleteObject( II.hbmColor );
- {$endif wince}
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //*
- //[procedure TIcon.SetSize]
- procedure TIcon.SetSize(const Value: Integer);
- begin
- {$IFDEF ICON_DIFF_WH}
- if (fWidth = Value) and (fHeight = Value) then Exit;
- {$ELSE}
- if FSize = Value then Exit;
- {$ENDIF}
- Clear;
- {$IFDEF ICON_DIFF_WH}
- fWidth := Value;
- fHeight := Value;
- {$ELSE}
- FSize := Value;
- {$ENDIF}
- end;
-
- {$IFDEF ICON_DIFF_WH}
- function TIcon.GetIconSize: Integer;
- begin
- Result := Max( fWidth, fHeight );
- end;
- {$ENDIF}
-
- //[FUNCTION ColorBits]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function ColorBits( ColorsCount : Integer ) : Integer;
- var I : Integer;
- begin
- for I := 1 to 6 do
- begin
- Result := PossibleColorBits[ I ];
- if (1 shl Result) >= ColorsCount then break;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END ColorBits]
-
- {$ifdef win32}
- //[function SaveIcons2StreamEx]
- function SaveIcons2StreamEx( const BmpHandles: array of HBitmap; Strm: PStream ): Boolean;
- var I, Off : Integer;
- IDI : TIconDirEntry;
- BIH : TBitmapInfoHeader;
- B: TagBitmap;
- function RGBArraySize : Integer;
- begin
- Result := 0;
- if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
- Result := (IDI.bColorCount + (IDI.bReserved shl 8)) * Sizeof( TRGBQuad );
- end;
- function ColorDataSize( W, H: Integer ) : Integer;
- var N: Integer;
- begin
- if (IDI.bColorCount >= 2) or (IDI.bReserved = 1) then
- N := (ColorBits( IDI.bColorCount + (IDI.bReserved shl 8) ) )
- else
- begin
- N := IDI.wBitCount;
- end;
- Result := ((N * W + 31) div 32) * 4
- * H;
- end;
- function MaskDataSize( W, H: Integer ) : Integer;
- begin
- Result := ((W + 31) div 32) * 4 * H;
- end;
- var BColor, BMask: HBitmap;
- W, H: Integer;
- ImgBmp, MskBmp: PBitmap;
- IH : TIconHeader;
- Colors : PList;
- begin
- Assert( (High(BmpHandles) >= 0) and (High(BmpHandles) and 1 <> 0),
- 'Incorrect parameters count in call to SaveIcons2StreamEx' );
- Result := False;
- IH.idReserved := 0;
- IH.idType := 1;
- IH.idCount := (High( BmpHandles )+1) div 2;
- if Strm.Write( IH, Sizeof( IH ) ) <> Sizeof( IH ) then Exit;
- Off := Sizeof( IH ) + IH.idCount * Sizeof( IDI );
- Colors := NewList;
- ImgBmp := NewBitmap( 0, 0 );
- MskBmp := NewBitmap( 0, 0 );
- TRY
-
- for I := 0 to High( BmpHandles ) div 2 do
- begin
- BColor := BmpHandles[ I * 2 ];
- BMask := BmpHandles[ I * 2 + 1 ];
- if (BColor = 0) and (BMask = 0) then break;
- Assert( BMask <> 0, 'Mask bitmap not provided for saving icons in SaveIcons2StreamEx' );
- GetObject( BMask, Sizeof( B ), @ B );
- W := B.bmWidth;
- H := B.bmHeight;
- if BColor <> 0 then
- begin
- GetObject( BColor, Sizeof( B ), @B );
- Assert( (B.bmWidth = W) and (B.bmHeight = H),
- 'Mask bitmap size must much color bitmap size in SaveIcons2StreamEx' );
- end;
- FillChar( IDI, Sizeof( IDI ), #0 );
-
- IDI.bWidth := W;
- IDI.bHeight := H;
- if BColor = 0 then
- IDI.bColorCount := 2
- else
- begin
- ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H,
- LR_CREATEDIBSECTION );
- FillChar( BIH, Sizeof( BIH ), #0 );
- BIH.biSize := Sizeof( BIH );
- GetObject( ImgBmp.Handle, Sizeof( B ), @B );
- if (B.bmPlanes = 1) and (B.bmBitsPixel >= 15) then
- begin
- IDI.bColorCount := 0;
- IDI.bReserved := 0;
- IDI.wBitCount := B.bmBitsPixel;
- end
- else
- if B.bmPlanes * (1 shl B.bmBitsPixel) < 16 then
- begin
- ImgBmp.PixelFormat := pf1bit;
- IDI.bColorCount := 2;
- end
- else
- if B.bmPlanes * (1 shl B.bmBitsPixel) < 256 then
- begin
- ImgBmp.PixelFormat := pf4bit;
- IDI.bColorCount := 16;
- end
- else
- begin
- ImgBmp.PixelFormat := pf8bit;
- IDI.bColorCount := 0;
- IDI.bReserved := 1;
- end;
- end;
- Colors.Add( Pointer(IDI.bColorCount + (IDI.bReserved shl 8)) );
- IDI.dwBytesInRes := Sizeof( BIH ) + RGBArraySize +
- ColorDataSize( W, H ) + MaskDataSize( W, H );
- IDI.dwImageOffset := Off;
- if Strm.Write( IDI, Sizeof( IDI ) ) <> Sizeof( IDI ) then Exit;
- Inc( Off, IDI.dwBytesInRes );
- end;
- for I := 0 to High( BmpHandles ) div 2 do
- begin
- BColor := BmpHandles[ I * 2 ];
- BMask := BmpHandles[ I * 2 + 1 ];
- if (BColor = 0) and (BMask = 0) then break;
- GetObject( BMask, Sizeof( B ), @ B );
- W := B.bmWidth;
- H := B.bmHeight;
-
- FillChar( BIH, Sizeof( BIH ), #0 );
- BIH.biSize := Sizeof( BIH );
- BIH.biWidth := W;
- BIH.biHeight := H;
- if BColor <> 0 then
- BIH.biHeight := W * 2;
- BIH.biPlanes := 1;
- PWord( @ IDI.bColorCount )^ := DWord( Colors.Items[ I ] );
- if IDI.wBitCount = 0 then
- IDI.wBitCount := ColorBits( PWord( @ IDI.bColorCount )^ );
- BIH.biBitCount := IDI.wBitCount;
- BIH.biSizeImage := Sizeof( BIH ) + ColorDataSize( W, H ) + MaskDataSize( W, H );
- if Strm.Write( BIH, Sizeof( BIH ) ) <> Sizeof( BIH ) then Exit;
- if BColor <> 0 then
- begin
-
- ImgBmp.Handle := CopyImage( BColor, IMAGE_BITMAP, W, H, 0 );
- case BIH.biBitCount of
- 1 : ImgBmp.PixelFormat := pf1bit;
- 4 : ImgBmp.PixelFormat := pf4bit;
- 8 : ImgBmp.PixelFormat := pf8bit;
- 16: ImgBmp.PixelFormat := pf16bit;
- 24: ImgBmp.PixelFormat := pf24bit;
- 32: ImgBmp.PixelFormat := pf32bit;
- end;
- end
- else
- begin
- ImgBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
- ImgBmp.PixelFormat := pf1bit;
- end;
- if ImgBmp.FDIBBits <> nil then
- begin
- if Strm.Write( Pointer(cardinal(ImgBmp.FDIBHeader) + Sizeof(TBitmapInfoHeader))^,
- PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad ) ) <>
- DWORD(PWord( @ IDI.bColorCount )^ * Sizeof( TRGBQuad )) then Exit;
- if Strm.Write( ImgBmp.FDIBBits^, ColorDataSize( W, H ) ) <>
- DWord( ColorDataSize( W, H ) ) then Exit;
- end;
- MskBmp.Handle := CopyImage( BMask, IMAGE_BITMAP, W, H, 0 );
-
- MskBmp.PixelFormat := pf1bit;
- if Strm.Write( MskBmp.FDIBBits^, MaskDataSize( W, H ) ) <>
- DWord( MaskDataSize( W, H ) ) then Exit;
- end;
-
- FINALLY
- Colors.Free;
- ImgBmp.Free;
- MskBmp.Free;
- END;
- Result := True;
- end;
-
- {$IFDEF FPC}
- {$DEFINE _D3orFPC}
- {$ENDIF}
- {$IFDEF _D2orD3}
- {$DEFINE _D3orFPC}
- {$ENDIF}
- //[procedure SaveIcons2Stream]
- procedure SaveIcons2Stream( const Icons : array of PIcon; Strm : PStream );
- var I, J, Pos : Integer;
- {$IFDEF _D3orFPC}
- Bitmaps: array[ 0..63 ] of HBitmap;
- {$ELSE DELPHI}
- Bitmaps: array of HBitmap;
- {$ENDIF FPC/DELPHI}
- II: TIconInfo;
- Bmp: HBitmap;
- begin
- for I := 0 to High( Icons ) do
- begin
- if Icons[ I ].Handle = 0 then Exit;
- for J := I + 1 to High( Icons ) do
- if Icons[ I ].Size = Icons[ J ].Size then Exit;
- end;
- Pos := Strm.Position;
-
- {$IFDEF _D3orFPC}
- for I := 0 to High( Bitmaps ) do
- Bitmaps[ I ] := 0;
- {$ELSE DELPHI}
- SetLength( Bitmaps, Length( Icons ) * 2 );
- {$ENDIF FPC/DELPHI}
- for I := 0 to High( Icons ) do
- begin
- GetIconInfo( Icons[ I ].Handle, II );
- Bitmaps[ I * 2 ] := II.hbmColor;
- Bitmaps[ I * 2 + 1 ] := II.hbmMask;
- end;
-
- if not SaveIcons2StreamEx( Bitmaps, Strm ) then
- Strm.Seek( Pos, spBegin );
-
- for I := 0 to High( Bitmaps ) do
- begin
- Bmp := Bitmaps[ I ];
- if Bmp <> 0 then
- DeleteObject( Bmp );
- end;
- end;
-
- //[procedure SaveIcons2File]
- procedure SaveIcons2File( const Icons : array of PIcon; const FileName : KOLString );
- var Strm: PStream;
- begin
- Strm := NewWriteFileStream( FileName );
- SaveIcons2Stream( Icons, Strm );
- Strm.Free;
- end;
- {$endif win32}
-
- //[procedure TIcon.LoadFromExecutable]
- procedure TIcon.LoadFromExecutable(const FileName: KOLString; IconIdx: Integer);
- var I: Integer;
- begin
- Clear;
- {$ifdef wince}
- if ExtractIconEx(PKOLChar( FileName ), IconIdx, @I, nil, 1) > 0 then
- {$else}
- I := ExtractIcon( hInstance, PKOLChar( FileName ), IconIdx );
- if I > 1 then
- {$endif wince}
- Handle := I;
- end;
-
- //[function GetFileIconCount]
- function GetFileIconCount( const FileName: KOLString ): Integer;
- begin
- {$ifdef wince}
- Result := ExtractIconEx(PKOLChar( FileName ), -1, nil, nil, 0);
- {$else}
- Result := ExtractIcon( hInstance, PKOLChar( FileName ), DWORD(-1) );
- {$endif wince}
- end;
-
- //[procedure TIcon.LoadFromResourceID]
- procedure TIcon.LoadFromResourceID(Inst, ResID, DesiredSize: Integer);
- begin
- LoadFromResourceName( Inst, MAKEINTRESOURCE( ResID ), DesiredSize );
- end;
-
- //[procedure TIcon.LoadFromResourceName]
- procedure TIcon.LoadFromResourceName(Inst: Integer; ResName: PKOLChar; DesiredSize: Integer);
- begin
- Handle := LoadImage( Inst, ResName, IMAGE_ICON, DesiredSize, DesiredSize, {$ifdef wince} 0 {$else} $8000 {LR_SHARED} {$endif} );
- {$ifdef wince}
- {$IFDEF ICON_DIFF_WH}
- fWidth := DesiredSize;
- fHeight := DesiredSize;
- {$ELSE}
- fSize := DesiredSize;
- {$ENDIF}
- {$endif wince}
- if fHandle <> 0 then FShareIcon := True;
- end;
-
- //[function LoadImgIcon]
- function LoadImgIcon( RsrcName: PKOLChar; Size: Integer ): HIcon;
- begin
- Result := LoadImage( hInstance, RsrcName, IMAGE_ICON, Size, Size, {$ifdef wince} 0 {$else} $8000 {LR_SHARED} {$endif} );
- end;
-
- //*
- //[procedure AlignChildrenProc]
- {$IFDEF OLD_ALIGN}
- procedure AlignChildrenProc( Sender: PObj );
- type
- TAligns = set of TControlAlign;
- var P: PControl;
- CR: TRect;
- procedure DoAlign( Allowed: TAligns );
- var I: Integer;
- C: PControl;
- R, R1: TRect;
- W, H: Integer;
- ChgPos, ChgSiz: Boolean;
- begin
- for I := 0 to P.fChildren.fCount - 1 do
- begin
- C := P.fChildren.fItems[ I ];
- if not C.ToBeVisible then continue;
- // important: not fVisible, and even not Visible, but ToBeVisible!
- if C.fNotUseAlign then continue;
- if C.FAlign in Allowed then
- begin
- R := C.BoundsRect;
- R1 := R;
- W := R.Right - R.Left;
- H := R.Bottom - R.Top;
- case C.FAlign of
- caTop:
- begin
- OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );
- Inc( CR.Top, H + P.Margin );
- R.Left := CR.Left + P.Margin;
- R.Right := CR.Right - P.Margin;
- end;
- caBottom:
- begin
- OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );
- Dec( CR.Bottom, H + P.Margin );
- R.Left := CR.Left + P.Margin;
- R.Right := CR.Right - P.Margin;
- end;
- caLeft:
- begin
- OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );
- Inc( CR.Left, W + P.Margin );
- R.Top := CR.Top + P.Margin;
- R.Bottom := CR.Bottom - P.Margin;
- end;
- caRight:
- begin
- OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );
- Dec( CR.Right, W + P.Margin );
- R.Top := CR.Top + P.Margin;
- R.Bottom := CR.Bottom - P.Margin;
- end;
- caClient:
- begin
- R := CR;
- InflateRect( R, -P.Margin, -P.Margin );
- end;
- end;
- if R.Right < R.Left then R.Right := R.Left;
- if R.Bottom < R.Top then R.Bottom := R.Top;
- ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);
- ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);
- if ChgPos or ChgSiz then
- begin
- C.BoundsRect := R;
- if ChgSiz then
- AlignChildrenProc( C );
- end;
- end;
- end;
- end;
- begin
- P := Pointer( Sender );
- if P = nil then Exit; // Called for form - ignore.
- CR := P.ClientRect;
- if CR.Right <= CR.Left then Exit;
- DoAlign( [ caTop, caBottom ] );
- DoAlign( [ caLeft, caRight ] );
- DoAlign( [ caClient ] );
- end;
- {$ELSE NEW_ALIGN}
-
- procedure AlignChildrenProc_(P:PControl);
- type TAligns = set of TControlAlign;
- var CR: TRect;
- procedure DoAlign( Allowed: TAligns );
- var I, W, H: Integer;
- C: PControl;
- R, R1: TRect;
- ChgPos, ChgSiz: Boolean;
- begin
- for I := 0 to P.fChildren.fCount - 1 do begin
- C := P.fChildren.fItems[ I ];
- with C{-}^{+} do begin
- if not (fVisible or fCreateHidden)
- or not (fAlign in Allowed)
- or (oaAligning in fAligning) then continue;
- if not fNotUseAlign and (fAlign <> caNone) then begin
- R := BoundsRect;
- R1 := R;
- W := R.Right - R.Left;
- H := R.Bottom - R.Top;
- case FAlign of
- caTop:
- begin
- OffsetRect( R, 0, -R.Top + CR.Top + P.Margin );
- Inc( CR.Top, H + P.Margin );
- R.Left := CR.Left + P.Margin;
- R.Right := CR.Right - P.Margin;
- end;
- caBottom:
- begin
- OffsetRect( R, 0, -R.Bottom + CR.Bottom - P.Margin );
- Dec( CR.Bottom, H + P.Margin );
- R.Left := CR.Left + P.Margin;
- R.Right := CR.Right - P.Margin;
- end;
- caLeft:
- begin
- OffsetRect( R, -R.Left + CR.Left + P.Margin, 0 );
- Inc( CR.Left, W + P.Margin );
- R.Top := CR.Top + P.Margin;
- R.Bottom := CR.Bottom - P.Margin;
- end;
- caRight:
- begin
- OffsetRect( R, -R.Right + CR.Right - P.Margin, 0 );
- Dec( CR.Right, W + P.Margin );
- R.Top := CR.Top + P.Margin;
- R.Bottom := CR.Bottom - P.Margin;
- end;
- caClient:
- begin
- R := CR;
- InflateRect( R, -P.Margin, -P.Margin );
- end;
- end;
- if R.Right < R.Left then R.Right := R.Left;
- if R.Bottom < R.Top then R.Bottom := R.Top;
- ChgPos := (R.Left <> R1.Left) or (R.Top <> R1.Top);
- ChgSiz := (R.Right - R.Left <> W) or (R.Bottom - R.Top <> H);
- if ChgPos or ChgSiz then begin
- include(fAligning,oaFromSelf);
- BoundsRect := R;
- exclude(fAligning,oaFromSelf);
- end;
- if ChgSiz then
- include(fAligning,oaWaitAlign);
- end;
- if oaWaitAlign in fAligning then AlignChildrenProc_(C);
- end;
- end;
- end;
- begin
- if oaAligning in P.fAligning then exit;
- exclude(P.fAligning,oaWaitAlign);
- if P.ChildCount = 0 then exit;
- include(P.fAligning,oaAligning);
- CR := P.ClientRect;
- DoAlign( [ caTop, caBottom ] );
- DoAlign( [ caLeft, caRight ] );
- DoAlign( [ caClient,caNone ] );
- exclude(P.fAligning,oaAligning);
- end;
-
- {$IFDEF ASM_VERSION}
- {$ELSE PAS_VERSION} // Pascal
- procedure AlignChildrenProc(Sender: PObj);
-
- function ToBeAlign( S: PControl ):boolean;
- begin
- Result := (S.fVisible or S.fCreateHidden)
- and (S.isForm or (S.fParent=nil) or ToBeAlign(S.fParent));
- if not Result then include(S.fAligning,oaWaitAlign);
- end;
-
- var
- S: PControl;
- begin
- if Sender = nil then Exit;
- S := Pointer( Sender );
- if oaFromSelf in S.fAligning then exit;
- if not (S.fNotUseAlign or (S.fAlign = caNone)) and (S.fParent <> nil) and not S.isForm then begin
- include(S.fAligning, oaWaitAlign);
- S := S.Parent;
- end;
- if ToBeAlign(S) then
- AlignChildrenProc_(S);
- end;
- {$ENDIF ASM_VERSION}
- {$ENDIF OLD_ALIGN}
-
- //*
- //[procedure TControl.Set_Align]
- procedure TControl.Set_Align(const Value: TControlAlign);
- begin
- Global_Align := AlignChildrenProc;
- if fNotUseAlign then Exit;
- if FAlign = Value then Exit;
- FAlign := Value;
- {$IFDEF OLD_ALIGN}
- AlignChildrenProc( Parent );
- {$ELSE NEW_ALIGN}
- AlignChildrenProc(@Self);
- {$ENDIF}
- end;
-
- //*
- //[function TControl.SetAlign]
- function TControl.SetAlign(AAlign: TControlAlign): PControl;
- begin
- Set_Align( AAlign );
- Result := @Self;
- end;
-
- //*
- //[function WndProcPreventResizeFlicks]
- function WndProcPreventResizeFlicks( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- type TRectsArray = array[0..2] of TRect;
- PRectsArray = ^TRectsArray;
- TChange = ( ChgL, ChgT, ChgR, ChgB );
- TChanges = Set of TChange;
- var Rects : PRectsArray;
- Changes : Set of TChange;
- Resizing : Boolean;
- X, Y, DX, DY : Integer;
- EntireRect, Src, Dst : TRect;
-
- function GetClientAfter : TRect;
- var R : TRect;
- begin
- R := Rects[ 2 ];
- OffsetRect( R, Rects[ 0 ].Left - Rects[ 1 ].Left,
- Rects[ 0 ].Top - Rects[ 1 ].Top );
- if Rects[ 0 ].Right - Rects[ 0 ].Left <> Rects[ 1 ].Right - Rects[ 1 ].Left then
- R.Right := R.Left + (R.Right - R.Left)
- + (Rects[ 0 ].Right - Rects[ 0 ].Left)
- - (Rects[ 1 ].Right - Rects[ 1 ].Left);
- if Rects[ 0 ].Bottom - Rects[ 0 ].Top <> Rects[ 1 ].Bottom - Rects[ 1 ].Top then
- R.Bottom := R.Top + (R.Bottom - R.Top)
- + (Rects[ 0 ].Bottom - Rects[ 0 ].Top)
- - (Rects[ 1 ].Bottom - Rects[ 1 ].Top);
- Result := R;
- end;
-
- procedure DoResize( F : PControl; Changes : TChanges );
-
- procedure CollectClipRgn( V : PControl; Changes : TChanges );
- var C : PControl;
- I : Integer;
- begin
- for I := 0 to V.FChildren.FCount - 1 do
- begin
- C := V.FChildren.FItems[ I ];
- if not C.Visible then Continue;
-
- if C.fNotUseAlign then
- begin
- C.Update;
- end;
- end;
- end; // of CollectClipRgn
-
- begin // DoResize
- CollectClipRgn( F, Changes );
- end; // of DoResize
-
- var PR: PRect;
- R: TRect;
- begin // Procedure WndProcResizeFlicks
- Result := False;
- case Msg.message of
- WM_NCCALCSIZE:
- if Msg.wParam <> 0 then
- begin
- Rects := Pointer( Msg.lParam );
- Changes := [];
- if Rects[ 0 ].Left <> Rects[ 1 ].Left then
- Changes := Changes + [ ChgL ];
- if Rects[ 0 ].Top <> Rects[ 1 ].Top then
- Changes := Changes + [ ChgT ];
- if Rects[ 0 ].Right <> Rects[ 1 ].Right then
- Changes := Changes + [ ChgR ];
- if Rects[ 0 ].Bottom <> Rects[ 1 ].Bottom then
- Changes := Changes + [ ChgB ];
- Resizing := Changes * [ ChgL, ChgT ] <> [ ];
- if Resizing and not Sender.fNotUseAlign then
- begin
- EntireRect := GetClientAfter;
- OffsetRect( EntireRect, -EntireRect.Left, -EntireRect.Top );
- if EntireRect.Right - EntireRect.Left < Rects[ 2 ].Right - Rects[ 2 ].Left then
- EntireRect.Right := Rects[ 2 ].Right - Rects[ 2 ].Left;
- if EntireRect.Bottom - EntireRect.Top < Rects[ 2 ].Bottom - Rects[ 2 ].Top then
- EntireRect.Bottom := Rects[ 2 ].Bottom - Rects[ 2 ].Top;
- X := Min( Rects[ 0 ].Left, Rects[ 1 ].Left ) + Rects[ 2 ].Left - Rects[ 1 ].Left;
- Y := Min( Rects[ 0 ].Top, Rects[ 1 ].Top ) + Rects[ 2 ].Top - Rects[ 2 ].Top;
- OffsetRect( EntireRect, X, Y );
- DX := 0; DY := 0;
- if ChgL in Changes then
- DX := Rects[ 0 ].Left - Rects[ 1 ].Left;
- if ChgR in Changes then
- DX := Rects[ 0 ].Right - Rects[ 1 ].Right;
- if ChgT in Changes then
- DY := Rects[ 0 ].Top - Rects[ 1 ].Top;
- if ChgB in Changes then
- DY := Rects[ 0 ].Bottom - Rects[ 1 ].Bottom;
- DoResize( Sender, Changes );
- Rslt := 0;
- if (Changes = [ChgL]) then
- begin
- Rslt := WVR_VALIDRECTS;
- Src := Rects[ 2 ];
- Dst := GetClientAfter;
- Src.Right := Src.Left - DX;
- Dst.Right := Dst.Left - DX;
- Rects[ 1 ] := Src;
- Rects[ 2 ] := Dst;
- end
- else
- if (Changes = [ChgR]) then
- begin
- Rslt := WVR_VALIDRECTS;
- Src := Rects[ 2 ];
- Dst := GetClientAfter;
- Src.Left := Src.Right - DX;
- Dst.Left := Dst.Right - DX;
- Rects[ 1 ] := Src;
- Rects[ 2 ] := Dst;
- end
- else
- if (Changes = [ChgT]) then
- begin
- Rslt := WVR_VALIDRECTS;
- Src := Rects[ 2 ];
- Dst := GetClientAfter;
- Src.Bottom := Src.Top - DY;
- Dst.Bottom := Dst.Top - DY;
- Rects[ 1 ] := Src;
- Rects[ 2 ] := Dst;
- end
- else
- if Changes = [ChgL,ChgT] then
- begin
- Rslt := WVR_VALIDRECTS;
- Src := Rects[ 2 ];
- Dst := GetClientAfter;
- Src.Left := Src.Right - DX;
- Dst.Left := Dst.Right - DX;
- Src.Bottom := Src.Top - DY;
- Dst.Bottom := Dst.Top - DY;
- Rects[ 1 ] := Src;
- Rects[ 2 ] := Dst;
- end;
- PostMessage( Sender.fHandle, CM_UPDATE, 0, 0 );
- end;
- end;
- CM_UPDATE:
- begin
- if Sender.fNotUpdate then
- begin
- Sender.fNotUpdate := False;
- Sender.Invalidate;
- end;
- Sender.Update;
- end;
- WM_SIZING:
- begin
- if (Msg.wParam = WMSZ_TOPLEFT) or (Msg.wParam = WMSZ_BOTTOMLEFT) or (Msg.wParam = WMSZ_TOPRIGHT) then
- begin
- PR := Pointer( Msg.lParam );
- GetWindowRect( Sender.fHandle, R );
- PostMessage( Sender.fHandle, CM_SIZEPOS, LoWord( PR.Left) or (PR.Top shl 16),
- LoWord( PR.Right - PR.Left ) or ( (PR.Bottom - PR.Top) shl 16) );
- if Msg.wParam = WMSZ_TOPLEFT then
- if Abs( R.Top - PR.Top ) < Abs( R.Left - PR.Left ) then
- PR.Top := R.Top
- else
- PR.Left := R.Left
- else
- if Msg.wParam = WMSZ_BOTTOMLEFT then
- if Abs( R.Bottom - PR.Bottom ) < Abs( R.Left - PR.Left ) then
- PR.Bottom := R.Bottom
- else
- PR.Left := R.Left
- else // WMSZ_TOPRIGHT
- if Abs( R.Top - PR.Top ) < Abs( R.Right - PR.Right ) then
- PR.Top := R.Top
- else
- PR.Right := R.Right;
- Sender.fNotUpdate := True;
- Rslt := 1;
- Result := TRUE;
- end;
- end;
- CM_SIZEPOS:
- begin
- Sender.fNotUpdate := False;
- SetWindowPos( Sender.fHandle, 0, SmallInt( LoWord( Msg.wParam ) ),
- SmallInt( HiWord( Msg.wParam ) ), SmallInt( LoWord( Msg.lParam ) ),
- SmallInt( HiWord( Msg.lParam ) ), SWP_NOZORDER or SWP_NOACTIVATE );
- end;
- WM_PAINT:
- begin
- if Sender.fNotUpdate then
- begin
- Rslt := 0;
- Result := True;
- end;
- end;
- WM_ERASEBKGND:
- begin
- if Sender.fNotUpdate then
- begin
- Rslt := 1;
- Result := True;
- end;
- end;
- end;
- end;
-
- //*
- //[function TControl.PreventResizeFlicks]
- function TControl.PreventResizeFlicks: PControl;
- begin
- fWndProcResizeFlicks := WndProcPreventResizeFlicks;
- Result := @Self;
- end;
-
- //*
- //[procedure TControl.Update]
- procedure TControl.Update;
- var I: Integer;
- C: PControl;
- begin
- if fUpdateCount > 0 then
- Exit;
- if fNotUpdate then Exit;
- if fHandle = 0 then Exit;
- UpdateWindow( fHandle );
- for I := 0 to fChildren.fCount - 1 do
- begin
- C := fChildren.fItems[ I ];
- C.Update;
- end;
- end;
-
- //[FUNCTION WndProcUpdate]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function WndProcUpdate( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if Sender.fUpdateCount <> 0 then
- begin
- case Msg.message of
- WM_PAINT:
- begin
- ValidateRect( Sender.Handle, nil );
- Rslt := 0;
- end;
- WM_ERASEBKGND: Rslt := 1;
- else begin
- Result := FALSE;
- Exit;
- end;
- end;
- Result := TRUE;
- end
- else Result := FALSE;
- end;
- {$ENDIF ASM_VERSION}
- //[END WndProcUpdate]
-
- //[procedure TControl.BeginUpdate]
- procedure TControl.BeginUpdate;
- begin
- Inc( fUpdateCount );
- AttachProc( @WndProcUpdate );
- end;
-
- //[procedure TControl.EndUpdate]
- procedure TControl.EndUpdate;
- begin
- Dec( fUpdateCount );
- if fUpdateCount <= 0 then
- begin
- Invalidate;
- //Update;
- end;
- end;
-
- //*
- //[function TControl.GetSelection]
- function TControl.GetSelection: KOLString;
- var L: Integer;
- begin
- if fCommandActions.aGetSelection <> 0 then
- begin
- L := SelLength;
- SetString( Result, nil, L + 1 );
- Perform( fCommandActions.aGetSelection, 0, Integer( @Result[ 1 ] ) );
- end
- else
- Result := Copy( Text, SelStart + 1, SelLength );
- end;
-
- //*
- //[procedure TControl.SetSelection]
- procedure TControl.SetSelection(const Value: KOLString);
- begin
- ReplaceSelection( Value, True );
- end;
-
- //*
- //[procedure TControl.ReplaceSelection]
- procedure TControl.ReplaceSelection(const Value: KOLString; aCanUndo: Boolean);
- begin
- if fCommandActions.aReplaceSel <> 0 then
- begin
- Perform( fCommandActions.aReplaceSel, Integer( aCanUndo ), Integer( PKOLchar( Value ) ) );
- end;
- end;
-
- //[procedure TControl.DeleteLines]
- procedure TControl.DeleteLines(FromLine, ToLine: Integer);
- var I1, I2: DWORD;
- SStart, SLength: DWORD;
- begin
- if FromLine > ToLine then Exit;
- Assert( FromLine >= 0, 'Incorrect line index' );
- I1 := Item2Pos( FromLine );
- I2 := Item2Pos( ToLine+1 ) - I1;
- SStart := SelStart;
- SLength := SelLength;
- SelStart := I1;
- {if ToLine >= Count-1 then
- I2 := MaxInt;}
- SelLength := I2;
- ReplaceSelection( '', TRUE );
- if SStart >= I2 then
- begin
- SStart := SStart - (I2 - I1);
- end
- else
- if SStart >= I1 then
- begin
- SLength := SLength - (I2 - SStart);
- SStart := I1;
- end
- else
- if SStart + SLength >= I2 then
- begin
- SLength := SLength - (I2 - I1);
- end
- else
- if SStart + SLength >= I1 then
- begin
- SLength := I1 - SLength;
- end;
- SelStart := SStart;
- SelLength := Max( 0, SLength );
- end;
-
- //*
- //[procedure TControl.SetTabOrder]
- procedure TControl.SetTabOrder(const Value: Integer);
- var CL: PList;
- I : Integer;
- C: PControl;
- begin
- if Value = fTabOrder then Exit;
- CL := CollectTabControls( ParentForm );
- for I := 0 to CL.fCount - 1 do
- begin
- C := CL.fItems[ I ];
- if C.fTabOrder >= Value then
- Inc( C.fTabOrder );
- end;
- fTabOrder := Value;
- CL.Free;
- end;
-
- //*
- //[function TControl.GetFocused]
- function TControl.GetFocused: Boolean;
- begin
- if fIsControl then
- Result := ParentForm.fCurrentControl = @Self
- else
- Result := GetForegroundWindow = fHandle;
- end;
-
- //*
- //[procedure TControl.SetFocused]
- procedure TControl.SetFocused(const Value: Boolean);
- var PF: PControl;
- begin
- if not Value or not fTabStop then Exit;
- if fIsControl then
- begin
- PF := ParentForm;
- if Assigned( PF.fCurrentControl ) and (PF.fCurrentControl <> @ Self) then
- if Assigned( PF.fCurrentControl.fLeave ) then
- PF.fCurrentControl.fLeave( PF.fCurrentControl )
- else
- Windows.SetFocus( 0 );
- PF.fCurrentControl := @Self;
- if Assigned( fSetFocus ) then
- fSetFocus
- else
- SetFocus( GetWindowHandle );
- end
- else
- SetForegroundWindow( GetWindowHandle );
- end;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- type
- PCharFormat = ^TCharFormat;
-
- //////////////////////////////////////////////////////////////////////
- // R I C H E D I T
- //////////////////////////////////////////////////////////////////////
-
- { -- rich edit -- }
-
- //*
- //[function TControl.REGetFont]
- function TControl.REGetFont: PGraphicTool;
- var CF: PCharFormat;
- FS: TFontStyle;
- begin
- CF := @fRECharFormatRec;
- FillChar( CF^, Sizeof( CF^ ), #0 );
- {$IFDEF UNICODE_CTRLS}
- CF.cbSize := Sizeof( CF^ );
- {$ELSE}
- CF.cbSize := sizeof( RichEdit.TCharFormat ) + fCharFmtDeltaSz;
- {$ENDIF}
- if fTmpFont = nil then
- begin
- fTmpFont := NewFont;
- {$IFDEF USE_AUTOFREE4CONTROLS}
- Add2AutoFree( fTmpFont );
- {$ENDIF}
- end;
- Result := fTmpFont;
- Result.OnChange := nil;
- Perform( EM_GETCHARFORMAT, 1, Integer( CF ) );
- Result.FontHeight := CF.yHeight;
- FS := [ ];
- if LongBool(CF.dwEffects and CFE_BOLD) then
- FS := [ fsBold ];
- if LongBool(CF.dwEffects and CFE_ITALIC) then
- FS := FS + [ fsItalic ];
- if LongBool(CF.dwEffects and CFE_STRIKEOUT) then
- FS := FS + [ fsStrikeOut ];
- if LongBool(CF.dwEffects and CFE_UNDERLINE) then
- FS := FS + [ fsUnderline ];
- Result.FontStyle := FS;
- if not LongBool(CF.dwEffects and CFE_AUTOCOLOR) then
- Result.Color := CF.crTextColor;
- Result.FontPitch := TFontPitch( CF.bPitchAndFamily and 3 );
- Result.FontCharset := CF.bCharSet;
- Result.FontName := CF.szFaceName;
- Result.OnChange := RESetFont;
- end;
-
- const RichAreas: array[ TRichFmtArea ] of Integer = ( SCF_SELECTION,
- SCF_WORD, 4 {SCF_ALL} );
-
- //*
- //[procedure TControl.RESetFontEx]
- procedure TControl.RESetFontEx(const Index: Integer);
- var CF: PCharFormat;
- FS: TFontStyle;
- begin
- CF := @fRECharFormatRec;
- FillChar( CF^, {82} sizeof( CF^ ), #0 );
- {$IFDEF UNICODE_CTRLS}
- CF.cbSize := Sizeof( CF^ );
- {$ELSE}
- CF.cbSize := 60 { sizeof( TCharFormat ) } + fCharFmtDeltaSz;
- {$ENDIF}
- CF.dwMask := CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
- or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE;
- CF.yHeight := fTmpFont.FontHeight;
- FS := fTmpFont.FontStyle;
- if fsBold in FS then CF.dwEffects := CFE_BOLD;
- if fsItalic in FS then CF.dwEffects := CF.dwEffects or CFE_ITALIC;
- if fsStrikeOut in FS then CF.dwEffects := CF.dwEffects or CFE_STRIKEOUT;
- if fsUnderline in FS then CF.dwEffects := CF.dwEffects or CFE_UNDERLINE;
- CF.crTextColor := Color2RGB(fTmpFont.Color);
- CF.bCharSet := fTmpFont.FontCharset;
- CF.bPitchAndFamily := Ord( fTmpFont.FontPitch );
- {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
- ( CF.szFaceName, PKOLChar( fTmpFont.FontName ), 31 );
- Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );
- end;
-
- //*
- //[procedure TControl.RESetFont]
- procedure TControl.RESetFont(Value: PGraphicTool);
- var H: Integer;
- begin
- if Value <> fTmpFont then
- REGetFont;
- H := fTmpFont.fData.Font.Height;
- fTmpFont := fTmpFont.Assign( Value );
- if fTmpFont.fData.Font.Height = 0 then
- fTmpFont.fData.Font.Height := H;
- RESetFontEx( Integer( CFM_BOLD or CFM_COLOR or CFM_FACE or CFM_ITALIC
- or CFM_SIZE or CFM_STRIKEOUT or CFM_UNDERLINE ) );
- end;
-
- //*
- //[function TControl.REGetFontMask]
- function TControl.REGetFontMask( const Index: Integer ): Boolean;
- begin
- REGetFont;
- Result := LongBool( fRECharFormatRec.dwMask and Index );
- end;
-
- //*
- //[function TControl.REGetFontEffects]
- function TControl.REGetFontEffects(const Index: Integer): Boolean;
- begin
- REGetFont;
- Result := LongBool( fRECharFormatRec.dwEffects and Index );
- end;
-
- //*
- //[procedure TControl.RESetFontEffect]
- procedure TControl.RESetFontEffect(const Index: Integer;
- const Value: Boolean);
- var CF: PCharFormat;
- begin
- ReGetFont;
- CF := @fRECharFormatRec;
- CF.dwEffects := $FFFFFFFF and Index;
- if not Value then CF.dwEffects := 0;
- CF.dwMask := Index;
- Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( CF ) );
- end;
-
- //*
- //[function TControl.REGetFontAttr]
- function TControl.REGetFontAttr(const Index: Integer): Integer;
- var CF: PDWORD;
- Mask: DWORD;
- begin
- REGetFont;
- CF := Pointer( cardinal( @fRECharFormatRec ) + (HiWord(Index) and $7E) );
- Mask := $FFFFFFFF;
- if LongBool( HiWord(Index) and $1 ) then
- Mask := $FF;
- Result := CF^ and Mask;
- end;
-
- //*
- //[procedure TControl.RESetFontAttr]
- procedure TControl.RESetFontAttr(const Index, Value: Integer);
- var CF: PDWORD;
- Mask: DWORD;
- begin
- REGetFont;
- CF := Pointer( cardinal( @fRECharFormatRec ) + (HiWord(Index) and $7E) );
- Mask := 0;
- if LongBool( HiWord(Index) and $1 ) then
- Mask := $FFFFFF00;
- CF^ := CF^ and Mask or DWORD(Value);
- fRECharFormatRec.dwMask := Index and $FF81FFFF;
- if LongBool( fRECharFormatRec.dwMask and (CFM_COLOR or CFM_BACKCOLOR) ) then
- fRECharFormatRec.dwEffects := fRECharFormatRec.dwEffects and
- not (CFE_AUTOCOLOR or CFE_AUTOBACKCOLOR);
- Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );
- end;
-
- //[procedure TControl.RESetFontAttr1]
- procedure TControl.RESetFontAttr1(const Index, Value: Integer);
- begin
- RESetFontAttr( Index, Color2RGB( Value ) );
- end;
-
- //*
- //[function TControl.REGetFontSizeValid]
- function TControl.REGetFontSizeValid: Boolean;
- begin
- Result := REGetFontMask( Integer( CFM_SIZE ) );
- end;
-
- //*
- //[function TControl.REGetFontName]
- function TControl.REGetFontName: KOLString;
- begin
- ReGetFont;
- Result := fRECharFormatRec.szFaceName;
- end;
-
- //*
- //[procedure TControl.RESetFontName]
- procedure TControl.RESetFontName(const Value: KOLString);
- begin
- ReGetFont;
- {$IFDEF UNICODE_CTRLS} WStrLCopy {$ELSE} StrLCopy {$ENDIF}
- ( fRECharFormatRec.szFaceName, PKOLChar( Value ), Sizeof( fRECharFormatRec.szFaceName ) - 1 );
- fRECharFormatRec.dwMask := CFM_FACE;
- Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @fRECharFormatRec ) );
- end;
-
- //*
- //[function TControl.REGetCharformat]
- function TControl.REGetCharformat: TCharFormat;
- begin
- REGetFont;
- Result := fRECharFormatRec;
- end;
-
- //*
- //[procedure TControl.RESetCharFormat]
- procedure TControl.RESetCharFormat(const Value: TCharFormat);
- begin
- Perform( EM_SETCHARFORMAT, RichAreas[ fRECharArea ], Integer( @Value ) );
- end;
-
- //*
- //[function REOut2Stream]
- function REOut2Stream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
- :DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- if Sz + Sender.fREStream.Position > Sender.fREStream.Size then
- Sender.fREStream.Size := Sender.fREStream.Size + DWORD( {Min(} Sz {, 8192 )} );
- pSz^ := Sender.fREStream.Write( Buf^, Sz );
- if Assigned( Sender.fOnProgress ) then
- Sender.fOnProgress( Sender );
- Result := 0;
- end;
-
- const TextTypes: array[ TRETextFormat ] of WORD = ( SF_RTF, SF_TEXT,
- SF_RTF or SFF_PLAINRTF, SF_RTFNOOBJS, SF_RTFNOOBJS or SFF_PLAINRTF,
- SF_TEXTIZED, {SF_UNICODE} $0010, $0010 or SF_TEXT );
-
- //*
- //[function TControl.RE_SaveToStream]
- function TControl.RE_SaveToStream(Stream: PStream; Format: TRETextFormat;
- SelectionOnly: Boolean): Boolean;
- var ES: TEditStream;
- SelFlag: Integer;
- begin
- fREStream := Stream;
- ES.dwCookie := Integer( @Self );
- ES.dwError := 0;
- ES.pfnCallback := @REOut2Stream;
- SelFlag := 0;
- if SelectionOnly then
- SelFlag := SFF_SELECTION;
- Perform( EM_STREAMOUT, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
- fREStream := nil;
- fREError := ES.dwError;
- Result := fREError = 0;
- end;
-
- //[procedure RE_AddText]
- procedure RE_AddText( Self_: PControl; const S: String );
- begin
- Self_.SelStart := Self_.TextSize;
- Self_.RE_Text[ reText, True ] := S;
- end;
-
- //*
- //[function TControl.REReadText]
- function TControl.REReadText(Format: TRETextFormat;
- SelectionOnly: Boolean): KOLString;
- var B0: Integer;
- MS: PStream;
- begin
- fCommandActions.aAddText := RE_AddText;
- MS := NewMemoryStream;
- RE_SaveToStream( MS, Format, SelectionOnly );
- B0 := 0;
- MS.Write( B0, Sizeof( KOLChar ) );
- if not (Format in [reUnicode,reTextUnicode]) then
- Result := PChar( MS.fMemory ) // must be PChar, not PKOLChar!
- else
- Result := PKOLChar( MS.fMemory );
- MS.Free;
- end;
-
- //*
- //[function REInFromStream]
- function REInFromStream( Sender: PControl; Buf: PByte; Sz: DWORD; pSz: PInteger )
- :DWORD; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- {$IFDEF _D3} if Sender.fREStrLoadLen >= 0 then {$ENDIF}
- if Sz > Sender.fREStrLoadLen then
- Sz := Sender.fREStrLoadLen;
- pSz^ := Sender.fREStream.Read( Buf^, Sz );
- Dec( Sender.fREStrLoadLen, pSz^ );
- if Assigned( Sender.fOnProgress ) then
- Sender.fOnProgress( Sender );
- Result := 0;
- end;
-
- //*
- //[function TControl.RE_LoadFromStream]
- function TControl.RE_LoadFromStream(Stream: PStream; Length: Integer;
- Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
- var ES: TEditStream;
- SelFlag: Integer;
- begin
- fREStream := Stream;
- fREStrLoadLen := DWORD( Length );
- ES.dwCookie := Integer( @Self );
- ES.dwError := 0;
- ES.pfnCallback := @REInFromStream;
- SelFlag := 0;
- if SelectionOnly then
- SelFlag := SFF_SELECTION;
- Perform( EM_STREAMIN, TextTypes[ Format ] or SelFlag, Integer( @ES ) );
- fREStream := nil;
- fREError := ES.dwError;
- Result := fREError = 0;
- end;
-
- //*
- //[procedure TControl.REWriteText]
- procedure TControl.REWriteText(Format: TRETextFormat;
- SelectionOnly: Boolean; const Value: KOLString);
- var MS: PStream;
- s: String; // not KOLString!
- begin
- fCommandActions.aAddText := RE_AddText;
- if not (Format in [reUnicode,reTextUnicode]) then
- begin
- s := Value;
- MS := NewExMemoryStream( @ s[ 1 ], Length( s ) );
- end
- else
- MS := NewExMemoryStream( @ Value[ 1 ], Length( Value ) * Sizeof( KOLChar ) );
- RE_LoadFromStream( MS, MS.fData.fSize, Format, SelectionOnly );
- MS.Free;
- end;
-
- //*
- //[function TControl.RE_LoadFromFile]
- function TControl.RE_LoadFromFile(const Filename: KOLString;
- Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( Filename );
- Result := RE_LoadFromStream( Strm, -1, Format, SelectionOnly );
- Strm.Free;
- end;
-
- //*
- //[function TControl.RE_SaveToFile]
- function TControl.RE_SaveToFile(const Filename: KOLString;
- Format: TRETextFormat; SelectionOnly: Boolean): Boolean;
- var Strm: PStream;
- begin
- Strm := NewWriteFileStream( Filename );
- Result := RE_SaveToStream( Strm, Format, SelectionOnly );
- Strm.Free;
- end;
-
- //*
- //[function TControl.REGetParaFmt]
- function TControl.REGetParaFmt: TParaFormat;
- begin
- FillChar( Result, sizeof( TParaFormat2 ), #0 );
- Result.cbSize := sizeof( RichEdit.TParaFormat ) + fParaFmtDeltaSz;
- Perform( EM_GETPARAFORMAT, 0, Integer( @Result ) );
- end;
-
- //*
- //[procedure TControl.RESetParaFmt]
- procedure TControl.RESetParaFmt(const Value: TParaFormat);
- begin
- //Value.cbSize := szTParaFmtRec;
- Perform( EM_SETPARAFORMAT, 0, Integer( @Value ) );
- end;
-
- //*
- //[function TControl.REGetNumbering]
- function TControl.REGetNumbering: Boolean;
- begin
- Result := LongBool( ReGetParaAttr( 9 shl 16 ) );
- end;
-
- //*
- //[function TControl.REGetParaAttr]
- function TControl.REGetParaAttr( const Index: Integer ): Integer;
- var pDw : PDWORD;
- begin
- fREParaFmtRec := REGetParaFmt;
- pDw := Pointer( cardinal( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
- Result := pDw^;
- if LongBool( HiWord( Index ) and 1 ) then
- Result := Result and $FFFF;
- end;
-
- //*
- //[function TControl.REGetParaAttrValid]
- function TControl.REGetParaAttrValid( const Index: Integer ): Boolean;
- begin
- Result := LongBool( ReGetParaAttr( 4 shl 16 ) and Index );
- end;
-
- //*
- //[function TControl.REGetTabCount]
- function TControl.REGetTabCount: Integer;
- begin
- Result := ReGetParaAttr( 27 shl 16 );
- end;
-
- //*
- //[function TControl.REGetTabs]
- function TControl.REGetTabs(Idx: Integer): Integer;
- begin
- Result := ReGetParaAttr( (28 + 4 * Idx) shl 16 );
- end;
-
- //*
- //[function TControl.REGetTextAlign]
- function TControl.REGetTextAlign: TRichTextAlign;
- begin
- Result := TRichTextAlign( ReGetParaAttr( 25 shl 16 ) - 1 );
- end;
-
- //*
- //[procedure TControl.RESetNumbering]
- procedure TControl.RESetNumbering(const Value: Boolean);
- begin
- RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Integer( Value ) );
- end;
-
- //*
- //[procedure TControl.RESetParaAttr]
- procedure TControl.RESetParaAttr(const Index, Value: Integer);
- var pDw: PDWORD;
- Mask: Integer;
- begin
- REGetParaAttr( 0 );
- pDw := Pointer( cardinal( @fREParaFmtRec ) + ( HiWord( Index ) and $7E ) );
- Mask := 0;
- if LongBool( HiWord( Index ) and 1 ) then
- Mask := Integer( $FFFF0000 );
- pDw^ := pDw^ and Mask or DWORD(Value);
- fREParaFmtRec.dwMask := Index and $8000FFFF;
- RESetParaFmt( fREParaFmtRec );
- end;
-
- //*
- //[procedure TControl.RESetTabCount]
- procedure TControl.RESetTabCount(const Value: Integer);
- begin
- REGetParaAttr( 0 );
- RESetParaAttr( (27 shl 16) or PFM_TABSTOPS, Value );
- end;
-
- //*
- //[procedure TControl.RESetTabs]
- procedure TControl.RESetTabs(Idx: Integer; const Value: Integer);
- begin
- REGetParaAttr( 0 );
- RESetParaAttr( (28 + 4 * Idx) or PFM_TABSTOPS, Value );
- end;
-
- //*
- //[procedure TControl.RESetTextAlign]
- procedure TControl.RESetTextAlign(const Value: TRichTextAlign);
- begin
- RESetParaAttr( (25 shl 16) or PFM_ALIGNMENT, Ord( Value ) + 1 );
- end;
-
- //*
- //[function TControl.REGetStartIndentValid]
- function TControl.REGetStartIndentValid: Boolean;
- begin
- Result := REGetParaAttrValid( Integer( PFM_STARTINDENT ) );
- end;
-
- //*
- //[procedure TControl.RE_HideSelection]
- procedure TControl.RE_HideSelection(aHide: Boolean);
- begin
- Perform( EM_HIDESELECTION, Integer( aHide ), 1 );
- end;
-
- //*
- //[function TControl.RE_SearchText]
- function TControl.RE_SearchText(const Value: KOLString; MatchCase,
- WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
- var Flags: Integer;
- FT: {$IFDEF UNICODE_CTRLS} TFindTextW {$ELSE}
- {$IFDEF _D2} TFindText {$ELSE} TFindTextA {$ENDIF} {$ENDIF};
- begin
- Flags := Integer( ScanForward );
- if WholeWord then Flags := Flags or FT_WHOLEWORD;
- if MatchCase then Flags := Flags or FT_MATCHCASE;
- FT.chrg.cpMin := SearchFrom;
- FT.chrg.cpMax := SearchTo;
- FT.lpstrText := PKOLChar( Value );
- Result := Perform( EM_FINDTEXT, Flags, Integer( @FT ) );
- end;
-
- {$IFNDEF _FPC}
- {$IFNDEF _D2} //------- WideString not supported in D2
- //[function TControl.RE_WSearchText]
- function TControl.RE_WSearchText(const Value: WideString; MatchCase,
- WholeWord, ScanForward: Boolean; SearchFrom, SearchTo: Integer): Integer;
- var Flags: Integer;
- FT: TFindTextW;
- begin
- Flags := Integer( ScanForward );
- if WholeWord then Flags := Flags or FT_WHOLEWORD;
- if MatchCase then Flags := Flags or FT_MATCHCASE;
- FT.chrg.cpMin := SearchFrom;
- FT.chrg.cpMax := SearchTo;
- FT.lpstrText := PWideChar( Value );
- Result := Perform( WM_USER+123 {EM_FINDTEXTW}, Flags, Integer( @FT ) );
- end;
- {$ENDIF}{$ENDIF}
-
- {$ENDIF NOT_USE_RICHEDIT}
-
- //*
- //[function TControl.CanUndo]
- function TControl.CanUndo: Boolean;
- begin
- Result := LongBool( Perform( EM_CANUNDO, 0, 0 ) );
- end;
-
- //*
- //[procedure TControl.EmptyUndoBuffer]
- procedure TControl.EmptyUndoBuffer;
- begin
- Perform( EM_EMPTYUNDOBUFFER, 0, 0 );
- end;
-
- //*
- //[function TControl.Undo]
- function TControl.Undo: Boolean;
- begin
- Result := LongBool( Perform( EM_UNDO, 0, 0 ) );
- end;
-
- //*
- //[function TControl.GetMaxTextSize]
- function TControl.GetMaxTextSize: DWORD;
- begin
- Result := Perform( EM_GETLIMITTEXT, 0, 0 );
- end;
-
- //*
- //[procedure TControl.SetMaxTextSize]
- procedure TControl.SetMaxTextSize(const Value: DWORD);
- var V1, V2: Integer;
- begin
- if fCommandActions.aSetLimit <> 0 then
- begin
- V1 := 0; V2 := Value;
- if fCommandActions.aSetLimit = EM_SETLIMITTEXT then
- begin
- V1 := Value; V2 := 0;
- end;
- Perform( fCommandActions.aSetLimit, V1, V2 );
- end;
- end;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- //*
- //[function TControl.RE_Redo]
- function TControl.RE_Redo: Boolean;
- begin
- Result := LongBool( Perform( EM_REDO, 0, 0 ) );
- end;
-
- //*
- //[function TControl.REGetAutoURLDetect]
- function TControl.REGetAutoURLDetect: Boolean;
- begin
- Result := LongBool( Perform( EM_GETAUTOURLDETECT, 0, 0 ) );
- end;
-
- //*
- //[procedure TControl.RESetAutoURLDetect]
- procedure TControl.RESetAutoURLDetect(const Value: Boolean);
- begin
- AttachProc( WndProc_RE_LinkNotify );
- Perform( EM_AUTOURLDETECT, Integer( Value ), 0 );
- end;
-
- procedure TControl.RESetZoom( const Value: TSmallPoint );
- begin
- Perform( EM_SETZOOM, Value.x, Value.y );
- end;
-
- function TControl.REGetZoom: TSmallPoint;
- var P: TPoint;
- begin
- Perform( EM_GETZOOM, Integer( @ P.X ), Integer( @ P.Y ) );
- Result := Point2SmallPoint( P );
- end;
-
- //*
- //[function WndProc_REFmt]
- function WndProc_REFmt( _Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Mask: Integer;
- Shft, Alt, Ctrl, Flg: Boolean;
- Delta: Integer;
- TA: TRichTextAlign;
- ChgTA: Boolean;
- US: TRichUnderline;
- NS: TRichNumbering;
- NB: TRichNumBrackets;
- Side: TBorderEdge;
- Param: DWORD;
- begin
- Result := False;
- if Msg.message = WM_CHAR then
- if _Self_.FSupressTab then
- begin
- _Self_.FSupressTab := FALSE;
- if Msg.wParam = 9 then
- begin
- Result := TRUE;
- Exit;
- end;
- end;
-
- if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
- begin
- Ctrl := GetKeyState( VK_CONTROL ) < 0;
- Alt := GetKeyState( VK_MENU ) < 0;
- Param := Msg.wParam;
- if Ctrl or
- Alt and IntIn(Param, [ VK_ADD, VK_SUBTRACT, Integer( '-' ), Integer( '=' ),
- Integer( '+' ), 189 {-}, 187 {+} ]) then
- begin
- Shft := GetKeyState( VK_SHIFT ) < 0;
- Rslt := 0;
- Result := True;
- Mask := 0;
- ChgTA := False; TA := raLeft;
- case Param of
- Integer('Z'):
- begin
- if Shft then
- begin
- _Self_.RE_Redo;
- Exit;
- end;
- Result := False;
- end;
-
- Integer('L'): begin ChgTA := True; TA := raLeft; end;
- Integer('R'): begin ChgTA := True; TA := raRight; end;
- Integer('E'): begin ChgTA := True; TA := raCenter; end;
- Integer('J'): begin ChgTA := True; TA := raJustify; end;
- Integer('N'): begin
- if Shft then
- begin
- NS := _Self_.RE_NumStyle;
- NB := _Self_.RE_NumBrackets;
- if NS = rnBullets then
- begin
- _Self_.RE_NumStyle := rnNone;
- Exit;
- end;
- if NS = rnNone then
- begin
- _Self_.RE_NumStyle := rnBullets;
- //NB := rnbPlain;
- Exit;
- end
- else
- if Ord( NB ) = 0 then
- NB := High(NB) else
- NB := Pred(NB);
- _Self_.RE_NumBrackets := NB;
- end
- else
- begin
- NS := _Self_.RE_NumStyle;
- if Ord( NS ) = 0 then
- begin
- NS := rnURoman; //rnULetter; //High( NS );
- { because rnLRoman, rnURoman, rnNoNumber are not shown
- in RichEdit. }
- _Self_.RE_NumBrackets := rnbPeriod;
- end else
- NS := Pred(NS);
- _Self_.RE_NumStyle := NS;
- if NS in [ rnLRoman, rnURoman, rnArabic ] then
- _Self_.RE_NumStart := 1;
- end;
- Exit;
- end;
- Integer('W'): begin
- Delta := _Self_.RE_BorderWidth[ beLeft ] + 4;
- if Shft then Delta := -1;
- for Side := Low(Side) to High(Side) do
- begin
- if Delta < 0 then
- _Self_.RE_BorderStyle[ Side ] := _Self_.RE_BorderStyle[ Side ] + 1
- else
- begin
- _Self_.RE_BorderWidth[ Side ] := Delta;
- _Self_.RE_BorderSpace[ Side ] := Delta;
- end;
- end;
- Exit;
- end;
- (* TABLES STUFF -- to try, uncomment it and press CTRL+T in RichEdit.
- (and uncomment declaration for Tmp above).
-
- Not finished, and seems no way to figure it out - even RichEdit20.dll
- (i.e. Rich Edit v3.0) can not display tables properly formatted. :(((
-
- Integer('T'): begin
- if _Self_.RE_Table then
- begin
- //MsgOK( 'table' );
- end;
- Tmp := _Self_.REReadText( reRTF, True );
- if StrIsStartingFrom( PChar(Tmp), '{\rtf' )
- and (CopyTail( Tmp, 3 ) = '}'#$D#$A) then
- begin
- //Tmp := Copy( Tmp, 1, Length(Tmp) - 3 );
- _Self_.RE_Text[ reRTF, True ] := '{\rtf1' + //Copy( Tmp, 1, 6 ) +
- '\trowd' +
- //'\lytcalctblwd' +
- //'\oldlinewrap' +
- //'\alntblind' +
- //'\trgaph108' +
- '\trleft-108' +
- {'\trbrdrt\brdrs\brdrw10' +
- '\trbrdrl\brdrs\brdrw10' +
- '\trbrdrb\brdrs\brdrw10' +
- '\trbrdrr\brdrs\brdrw10' +
- '\trbrdrh\brdrs\brdrw10' +
- '\trbrdrv\brdrs\brdrw10' +}
- //'\clvertalt' +
- {'\clbrdrt\brdrs\brdrw10' +
- '\clbrdrl\brdrs\brdrw10' +
- '\clbrdrb\brdrs\brdrw10' +
- '\clbrdrr\brdrs\brdrw10' +}
- //'\cltxlrtb' +
- '\cellx1414' +
- //'\pard' +
- //'\plain' +
- //'\widctlpar' +
- '\trautofit1' +
- '\intbl' +
- //'\adjustright' +
- //'\fs20\lang1049' +
- //'\cgrid' +
- '\trrh0' +
- '{\clFitText{{\box\brdrs\brdrw20\brsp20}'+
- '\par}\cell\row}' +
- //'\pard\widctlpar' +
- //'\intbl'+
- //'\adjustright'+
- //'{\row}' +
- '\pard\widctlpar' +
- '}'#$D#$A;
- _Self_.Perform( WM_KEYDOWN, VK_UP, 0 );
- _Self_.Perform( WM_KEYUP, VK_UP, 0 );
- end;
- Exit;
- end;
- *)
- Integer('B'): Mask := CFM_BOLD;
- Integer('I'):
- begin
- Mask := CFM_ITALIC;
- _Self_.FSupressTab := TRUE;
- end;
- Integer('U'):
- begin
- if Shft then
- begin
- US := _Self_.RE_FmtUnderlineStyle;
- if Ord(US) = 0 then US := High(TRichUnderLine)
- else US := Pred( US );
- _Self_.RE_FmtUnderlineStyle := US;
- Exit;
- end;
- Mask := CFM_UNDERLINE;
- end;
- Integer('O'): Mask := CFM_STRIKEOUT;
- VK_SUBTRACT, VK_ADD, Integer( '+' ), 187, Integer( '-' ), 189:
- ;
- else
- begin
- Result := False;
- Msg.wParam := Param;
- end;
- end;
- if not Result then Exit;
-
- if ChgTA then
- begin
- if Shft then Result := False
- else _Self_.RE_TextAlign := TA;
- Exit;
- end;
-
- _Self_.REGetFont;
- if Mask > 0 then
- begin
- if Shft then Result := False
- else begin
- Flg := _Self_.REGetFontEffects( Mask );
- if not Flg then
- _Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects and not Mask;
- _Self_.fRECharFormatRec.dwEffects := _Self_.fRECharFormatRec.dwEffects xor DWORD(Mask);
- end;
- end
- else
- if IntIn( Param, [ VK_ADD, VK_SUBTRACT, Integer( '+' ),
- Integer( '-' ), 189, 187 ] ) then
- begin
- if (Param = VK_SUBTRACT) or (Param = DWORD( '-' )) or (Param = 189) then
- Delta := -1
- else
- Delta := 1;
- if Alt and Ctrl then
- begin
- Mask := Integer( CFM_SIZE ) or Integer( CFM_OFFSET );
- Delta := 0;
- _Self_.fRECharFormatRec.yOffset := 0;
- _Self_.fRECharFormatRec.yHeight := 200;
- end
- else
- if Alt then Mask := Integer( CFM_SIZE )
- else Mask := Integer( CFM_OFFSET );
- Inc( _Self_.fRECharFormatRec.yOffset, Delta * _Self_.fRECharFormatRec.yHeight div 3 );
- Inc( _Self_.fRECharFormatRec.yHeight, Delta * _Self_.fRECharFormatRec.yHeight div 8 );
- Flg := LongBool( _Self_.fRECharFormatRec.dwMask and Mask );
- if not Flg then
- _Self_.fRECharFormatRec.yOffset := 0;
- end;
- _Self_.fRECharFormatRec.dwMask := Mask;
- if _Self_.SelLength = 0 then
- _Self_.SelLength := 1;
- _Self_.Perform( EM_SETCHARFORMAT, SCF_SELECTION { RichAreas[ _Self_.fRECharArea ] }, Integer( @_Self_.fRECharFormatRec ) );
- end;
- end;
- end;
-
- //*
- //[function TControl.RE_FmtStandard]
- function TControl.RE_FmtStandard: PControl;
- begin
- AttachProc( WndProc_REFmt );
- Result := @Self;
- end;
-
- procedure TControl.RE_CancelFmtStandard;
- begin
- DetachProc( WndProc_REFmt );
- end;
- {$ENDIF NOT_USE_RICHEDIT}
-
- //[FUNCTION EnumDynHandlers]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function EnumDynHandlers( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- Proc: TWindowFunc;
- begin
- Result := False;
- if Self_.fRefCount < 0 then Exit;
- if (Self_.fDynHandlers = nil) or (Self_.fDynHandlers.fCount = 0) then Exit;
- Self_.RefInc; // Prevent destroying Self_
- for I := Self_.fDynHandlers.fCount div 2 - 1 downto 0 do
- begin
- Proc := Self_.fDynHandlers.fItems[ I * 2 ];
- {$IFNDEF SMALLEST_CODE}
- {$IFNDEF ENUM_DYN_HANDLERS_AFTER_RUN}
- if not AppletTerminated or (Self_.fDynHandlers.fItems[ I * 2 + 1 ] <> nil) then
- {$ENDIF}
- {$ENDIF}
- if Proc( Self_, Msg, Rslt ) then
- begin
- Result := True;
- break;
- end;
- end;
- {$IFDEF DEBUG_ENDSESSION}
- if EndSession_Initiated then
- begin
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'ENUM_DYN_HANDLERS: Self_:' + Int2Hex( DWORD( Self_ ), 8 ) );
- LogFileOutput( GetStartDir + 'es_debug.txt',
- 'ENUM_DYN_HANDLERS: Self_.fRefCount:' + Int2Str( Self_.fRefCount ) );
- end;
- {$ENDIF}
- if LongBool(Self_.fRefCount and 1) then
- Result := True; // If Self_ will be destroyed now, stop further processing
- Self_.RefDec; // Destroy Self_, if Free was called for it while processing attached procedures
- end;
- {$ENDIF ASM_VERSION}
- //[END EnumDynHandlers]
- {$ifdef win32}
- procedure TransparentAttachProcExtension ( DynHandlers: PList );
- var i: integer;
- begin
- I := DynHandlers.IndexOf( @WndProcTransparent );
- if I >=0 then begin
- DynHandlers.Delete( I );
- DynHandlers.Delete( I );
- DynHandlers.Add( @WndProcTransparent );
- DynHandlers.Add( nil );
- end;
- end;
- {$endif win32}
- procedure DummyAttachProcExtension ( DynHandlers: PList );
- begin
- end;
-
- //[procedure TControl.AttachProcEx]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- procedure TControl.AttachProcEx( Proc: TWindowFunc; ExecuteAfterAppletTerminated: Boolean );
- begin
- //if fDynHandlers = nil then
- // fDynHandlers := NewList;
- if not IsProcAttached( Proc ) then
- begin
- fDynHandlers.Add( @Proc );
- fDynHandlers.Add( Pointer( Integer( ExecuteAfterAppletTerminated ) ) );
- end;
- {$IFNDEF SMALLEST_CODE}
- Global_AttachProcExtension(fDynHandlers);
- {$ENDIF}
- fOnDynHandlers := EnumDynHandlers;
- end;
- {$ENDIF ASM_VERSION}
-
- //[procedure TControl.AttachProc]
- procedure TControl.AttachProc(Proc: TWindowFunc);
- begin
- AttachProcEx( Proc, FALSE );
- end;
-
- //*
- //[procedure TControl.DetachProc]
- procedure TControl.DetachProc(Proc: TWindowFunc);
- var I: Integer;
- begin
- if fDynHandlers = nil then Exit;
- I := fDynHandlers.IndexOf( @Proc );
- if I >=0 then
- begin
- fDynHandlers.Delete( I );
- fDynHandlers.Delete( I );
- end;
- end;
-
- //[function TControl.IsProcAttached]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION} //Pascal
- function TControl.IsProcAttached(Proc: TWindowFunc): Boolean;
- var I: Integer;
- begin
- //Result := False;
- //if fDynHandlers = nil then Exit;
- I := fDynHandlers.IndexOf( @Proc );
- Result := I >=0;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function WndProcAutoPopupMenu]
- function WndProcAutoPopupMenu( Control: PControl; var Msg: TMsg; var MsgRslt: Integer ): Boolean;
-
- function GetMenuPoint: TPoint;
- var
- R: TRect;
- I, M: Integer;
- begin
- R:=Control.ClientRect;
- Result.x:=(R.Left + R.Right) div 2;
- Result.y:=R.Bottom;
- I := Control.CurIndex;
- M := Control.fCommandActions.aItem2XY;
- if (I >= 0) and (M <> 0) then begin
- CASE M OF
- EM_POSFROMCHAR:
- begin
- I := Control.SelStart + Control.SelLength;
- I := Control.Perform( M, I, 1 );
- Result.X := SmallInt( LoWord( I ) );
- Result.Y := SmallInt( HiWord( I ) );
- end;
- LB_GETITEMRECT, LVM_GETITEMRECT, TCM_GETITEMRECT:
- begin
- R.Left := LVIR_BOUNDS;
- Control.Perform( M, I, Integer( @ R ) );
- R.Left:=Max(R.Left, 0);
- R.Right:=Min(R.Right, ScreenWidth);
- Result.X := (R.Left + R.Right) div 2;
- Result.Y := R.Bottom;
- end;
- TVM_GETITEMRECT:
- begin
- I := Control.TVSelected;
- R.Left := I;
- Control.Perform( M, 1, Integer( @ R ) );
- Result.X := (R.Left + R.Right) div 2;
- Result.Y := R.Bottom;
- end;
- END;
- R := Control.ClientRect;
- if Result.X < R.Left then Result.X := R.Left;
- if Result.X > R.Right then Result.X := R.Right;
- if Result.Y < R.Top then Result.Y := R.Top;
- if Result.Y > R.Bottom then Result.Y := R.Bottom;
- end;
- end;
-
- var P: TPoint;
- {$ifdef wince}
- shrg: SHRGINFO;
- {$endif wince}
- begin
- {$ifdef wince}
- if (Control.fAutoPopupMenu <> nil) and ((Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_KEYDOWN)) then begin
- if Msg.message = WM_KEYDOWN then
- P:=GetMenuPoint
- else begin
- P.X := SmallInt( LoWord( Msg.lParam ) );
- P.Y := SmallInt( HiWord( Msg.lParam ) );
- end;
- with shrg do begin
- cbSize:=SizeOf(shrg);
- hwndClient:=Control.Handle;
- ptDown.x:=P.X;
- ptDown.y:=P.Y;
- dwFlags:=SHRG_RETURNCMD;
- end;
- if (SHRecognizeGesture(shrg) = GN_CONTEXTMENU) and (Msg.message = WM_KEYDOWN) then begin
- MsgRslt:=0;
- Result:=True;
- end
- else
- Result:=False;
- end
- else
- {$endif wince}
- if (Msg.message = WM_CONTEXTMENU) and
- (Control.fAutoPopupMenu <> nil) then
- begin
- {$IFDEF USE_MENU_CURCTL}
- PMenu( Control.fAutoPopupMenu ).fCurCtl := Control;
- {$ENDIF USE_MENU_CURCTL}
- if (Msg.lParam = -1) then
- P:=Control.Client2Screen(GetMenuPoint)
- else begin
- P.X := SmallInt( LoWord( Msg.lParam ) );
- P.Y := SmallInt( HiWord( Msg.lParam ) );
- end;
- PMenu( Control.fAutoPopupMenu ).Popup( P.X, P.Y );
- Result := TRUE;
- end
- else
- Result := FALSE;
- end;
-
- //[procedure TControl.SetAutoPopupMenu]
- procedure TControl.SetAutoPopupMenu(PopupMenu: PObj);
- { new version - by Alexander Pravdin. Allows to attach a submenu (e.g. of the
- main menu) as a popup menu to a control, to avoid duplicating menu object,
- if it is the same already as desired. }
- var pm: PMenu;
- begin
- if PopupMenu <> nil then
- {$IFDEF USE_MENU_CURCTL}
- begin
- pm := PMenu( PopupMenu );
- if ( pm.FParentMenu <> nil ) then
- begin
- while pm.FControl = nil do
- pm := pm.FParentMenu;
- PMenu( PopupMenu ).FControl := pm.FControl;
- end
- else
- if pm.FControl = nil then
- PMenu( PopupMenu ).FControl := @Self;
- AttachProc(WndProcAutoPopupMenu);
- AttachProc(WndProcMenu)
- end
- else begin
- DetachProc(WndProcAutoPopupMenu);
- DetachProc(WndProcMenu);
- end;
- {$ELSE}
- begin
- pm := PMenu( PopupMenu );
- while pm.FControl = nil do pm := pm.Parent;
- PMenu( PopupMenu ).FControl := pm.FControl;
- end;
- {$ENDIF}
- fAutoPopupMenu := PopupMenu;
- {$IFNDEF USE_MENU_CURCTL}
- AttachProc( WndProcAutoPopupMenu );
- {$ENDIF}
- end;
-
- {$ifdef win32}
- //[function SearchAnsiMnemonics]
- function SearchAnsiMnemonics( const S: KOLString ): KOLString;
- var I: Integer;
- Sh: ShortInt;
- begin
- Result := S;
- for I := 1 to Length( Result ) do
- begin
- Sh := VkKeyScanEx( Result[ I ], MnemonicsLocale );
- if Sh <> -1 then
- Result[ I ] := KOLChar( Sh );
- end;
- end;
-
- //[procedure SupportAnsiMnemonics]
- procedure SupportAnsiMnemonics( LocaleID: Integer );
- begin
- MnemonicsLocale := LocaleID;
- SearchMnemonics := SearchAnsiMnemonics;
- end;
-
- //[function WndProcMnemonics]
- function WndProcMnemonics( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Form: PControl;
-
- function HandleMnemonic( Prnt: PControl ): Boolean;
- var C: PControl;
- XY: Integer;
- procedure DoPressMnemonic;
- begin
- if Msg.message = WM_SYSKEYDOWN then
- begin
- Form.FPressedMnemonic := Msg.wParam;
- C.Perform( WM_LBUTTONDOWN, MK_LBUTTON, XY );
- end
- else
- begin
- Form.FPressedMnemonic := 0;
- C.Perform( WM_LBUTTONUP, MK_LBUTTON, XY );
- end;
- end;
- var I, J: Integer;
- R: TRect;
- begin
- for I := 0 to Prnt.ChildCount-1 do
- begin
- C := Prnt.Children[ I ];
- if not C.Visible then continue; // {YS} Do not process hidden controls
- if C.IsButton then
- if C.Enabled then
- begin
- if C.fCommandActions.aGetCount = TB_BUTTONCOUNT then
- for J := 0 to C.Count-1 do
- begin
- if C.TBButtonEnabled[ J ] then
- if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.TBButtonText[ J ] ) ) > 0 then
- begin
- C.fCurIndex := J;
- C.fCurItem := C.TBIndex2Item( J );
- R := C.TBButtonRect[ J ];
- XY := R.Left or (R.Top shl 16);
- DoPressMnemonic;
- Result := TRUE;
- Exit;
- end;
- end;
- if pos( '&' + Char( Msg.wParam ), SearchMnemonics( C.Caption ) ) > 0 then
- begin
- XY := 0;
- DoPressMnemonic;
- Result := TRUE;
- Exit;
- end;
- end;
- if HandleMnemonic( C ) then
- begin
- Result := TRUE;
- Exit;
- end;
- end;
- Result := FALSE;
- end;
-
- {$IFDEF NEW_MENU_ACCELL}
- function FindByCtlRef(C: PControl; Accell: TMenuAccelerator): Boolean;
-
- function FindInMenu(M: PMenu): PMenu;
- var
- I: Integer;
- SM: PMenu;
- begin
- for I := 0 to M.FItems.Count - 1 do begin
- Result := M.FItems.Items[I];
- if (Cardinal(Result.Accelerator) = Cardinal(Accell)) and Result.Enabled then
- Exit;
- end;
- Result := nil;
- for I := 0 to M.FItems.Count - 1 do begin
- SM := PMenu(M.FItems.Items[I]);
- if (SM.FItems.Count > 0) then
- Result := FindInMenu(SM);
- if (Result <> nil) then
- Break;
- end;
- end;
-
- function FindInMenu2(M: PMenu): Boolean;
- var
- MI: PMenu;
- begin
- if (M <> nil) then begin
- MI := FindInMenu(M);
- if (MI <> nil) then begin
- //M.FControl.Perform(WM_COMMAND, MI.FId, 0);
- C.Perform(WM_COMMAND, MI.FId, 0); // fixed
- Result := True;
- Exit;
- end;
- end;
- Result := False;
- end;
-
- var
- Parent: PControl;
- begin
- Result := False;
- if not FindInMenu2(PMenu(C.fAutoPopupMenu)) then
- if not FindInMenu2(PMenu(C.fMenuObj)) then begin
- Parent := C.Parent;
- if (Parent <> nil) then
- Result := FindByCtlRef(Parent, Accell);
- end;
- end;
-
- var
- Ac: TMenuAccelerator;
- {$ENDIF}
- begin
- Result := FALSE;
- if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
- begin
- {$IFDEF NEW_MENU_ACCELL}
- Ac := MakeAccelerator(FVIRTKEY or GetShiftState, Msg.wParam);
- Result := FindByCtlRef(Sender, Ac);
- {$ELSE}
- if (Sender.fAccelTable <> 0)
- {$IFDEF KEY_PREVIEW}
- and (Sender.FKeyPreviewCount = 0)
- {$ENDIF}
- then
- Result := LongBool( TranslateAccelerator( Sender.fHandle, Sender.fAccelTable, Msg ) );
- if not Result then
- begin
- if Sender.fCurrentControl <> nil then
- if Sender.fCurrentControl.fAccelTable <> 0 then
- Result := LongBool( TranslateAccelerator( Sender.fCurrentControl.fHandle,
- Sender.fCurrentControl.fAccelTable, Msg ) );
- end;
- if not Result then
- begin
- Form := Sender.ParentForm;
- if (Form <> nil) and (Form <> Sender)
- {$IFDEF KEY_PREVIEW}
- and (Form.FKeyPreviewCount = 0)
- {$ENDIF KEY_PREVIEW}
- then
- if Form.fAccelTable <> 0 then
- Result := LongBool( TranslateAccelerator( Form.fHandle,
- Form.fAccelTable, Msg ) );
- end;
- {$ENDIF}
- end;
- if Result then Exit;
- if (Msg.message = WM_SYSKEYUP) or
- (Msg.message = WM_SYSKEYDOWN) and (GetKeyState( VK_MENU ) < 0) then
- begin
- Rslt := 0;
- Form := Sender.ParentForm;
- if Form <> nil then
- begin
- if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
- begin
- if HandleMnemonic( Form ) then
- begin
- Result := TRUE;
- Exit;
- end;
- end;
- end;
- end
- else
- if Msg.message = WM_KEYUP then
- begin
- Rslt := 0;
- Form := Sender.ParentForm;
- if Form <> nil then
- begin
- if Msg.wParam = VK_MENU then
- begin
- if Form.FPressedMnemonic <> 0 then
- Form.FPressedMnemonic := Form.FPressedMnemonic or $80000000;
- end
- else
- if Char( Msg.wParam ) in [ 'A'..'Z', '0'..'9' ] then
- begin
- if HandleMnemonic( Form ) then
- begin
- Result := TRUE;
- Exit;
- end;
- end;
- end;
- end;
- Result := FALSE;
- end;
- {$endif win32}
- //[function TControl.SupportMnemonics]
- function TControl.SupportMnemonics: PControl;
- begin
- {$ifdef win32}
- fGlobalProcKeybd := WndProcMnemonics;
- {$endif win32}
- Result := @Self;
- end;
-
- //*
- //[procedure TControl.SelectAll]
- procedure TControl.SelectAll;
- begin
- SelStart := 0;
- SelLength := -1; // this can be not working for some controls... //*//*
- end;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- //*
- //[API RevokeDragDrop]
- function RevokeDragDrop(wnd: HWnd): HResult; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external 'ole32.dll' name 'RevokeDragDrop';
-
- //*
- //[function TControl.RE_NoOLEDragDrop]
- function TControl.RE_NoOLEDragDrop: PControl;
- begin
- RevokeDragDrop( Handle );
- Result := @Self;
- end;
- {$ENDIF NOT_USE_RICHEDIT}
-
- //*
- //[function WndProcOnResize]
- function WndProcOnResize( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if Msg.message = WM_SIZE then
- begin
- if Assigned( Self_.fOnResize ) then
- Self_.fOnResize( Self_ );
- end;
- Result := False;
- end;
-
- //*
- //[procedure TControl.SetOnResize]
- procedure TControl.SetOnResize(const Value: TOnEvent);
- begin
- FOnResize := Value;
- AttachProc( WndProcOnResize );
- end;
-
- //[function WndProcMove]
- function WndProcMove( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if Msg.message = WM_MOVE then
- begin
- if Assigned( Self_.FOnMove ) then
- Self_.FOnMove( Self_ );
- end;
- Result := False;
- end;
-
- //[procedure TControl.SetOnMove]
- procedure TControl.SetOnMove(const Value: TOnEvent);
- begin
- FOnMove := Value;
- AttachProc( WndProcMove );
- end;
-
- //[function WndProcMove]
- function WndProcMoving( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := False;
- if Msg.message = WM_MOVING then
- begin
- if Assigned( Self_.FOnMoving ) then
- Self_.FOnMoving( Self_, Pointer( Msg.lParam ) );
- Rslt := 1;
- Result := TRUE;
- end;
- end;
-
- procedure TControl.SetOnMoving(const Value: TOnEventMoving);
- begin
- FOnMoving := Value;
- AttachProc( WndProcMoving );
- end;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- //[function WndProc_REBottomless]
- function WndProc_REBottomless( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if Msg.message = WM_SIZE then
- Self_.Perform( EM_REQUESTRESIZE, 0, 0 );
- Result := False;
- end;
-
- //*
- //[function TControl.RE_Bottomless]
- function TControl.RE_Bottomless: PControl;
- begin
- AttachProc( WndProc_REBottomless );
- Result := @Self;
- end;
-
- //*
- //[procedure TControl.RE_Append]
- procedure TControl.RE_Append(const S: KOLString; ACanUndo: Boolean);
- begin
- SelStart := TextSize;
- if S <> '' then
- begin
- ReplaceSelection( S, ACanUndo );
- SelStart := TextSize;
- end;
- end;
-
- //*
- //[procedure TControl.RE_InsertRTF]
- procedure TControl.RE_InsertRTF(const S: KOLString);
- var MS: PStream;
- begin
- MS := NewMemoryStream;
- MS.Size := (Length( S ) + 1) * Sizeof(KOLChar);
- Move( S[ 1 ], MS.Memory^, ( Length( S ) + 1 ) * Sizeof( KOLChar ) );
- RE_LoadFromStream( MS, Length( S ), reRTF, TRUE );
- MS.Free;
- end;
- {$ENDIF NOT_USE_RICHEDIT}
-
- //*
- //[procedure TControl.DoSelChange]
- procedure TControl.DoSelChange;
- begin
- if Assigned( fOnSelChange ) then fOnSelChange( @Self )
- else
- if Assigned( fOnChange ) then fOnChange( @Self );
- end;
-
- //*
- //[function TControl.GetTextSize]
- function TControl.GetTextSize: Integer;
- begin
- Result := 0;
- if fHandle <> 0 then
- Result := GetWindowTextLength( fHandle );
- end;
-
- {$IFNDEF NOT_USE_RICHEDIT}
- //*
- //[function TControl.REGetUnderlineEx]
- function TControl.REGetUnderlineEx: TRichUnderline;
- begin
- Result := TRichUnderline( REGetFontAttr( ((81
- {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
- shl 16) or CFM_UNDERLINETYPE ) - 1 );
- end;
-
- //*
- //[procedure TControl.RESetUnderlineEx]
- procedure TControl.RESetUnderlineEx(const Value: TRichUnderline);
- begin
- RESetFontAttr( ((81
- {$IFDEF UNICODE_CTRLS} + 32 {$ENDIF})
- shl 16) or CFM_UNDERLINETYPE, Ord( Value ) + 1 );
- RESetFontEffect( CFM_UNDERLINE, True );
- end;
-
- //*
- //[function TControl.REGetTextSize]
- function TControl.REGetTextSize(Units: TRichTextSize): Integer;
- const TextLengthFlags: array[ TRichTextSizes ] of Integer =
- ( not GTL_UseCRLF, not GTL_Precise, GTL_Close, GTL_NUMBytes );
- var GTL: TGetTextLengthEx;
- begin
- GTL.flags := MakeFlags( @Units, TextLengthFlags );
- if not(rtsBytes in Units) then
- GTL.flags := GTL.flags or GTL_NUMCHARS;
- GTL.codepage := CP_ACP;
- Result := Perform( EM_GETTEXTLENGTHEX, Integer( @GTL ), 0 );
- end;
-
- //[function TControl.RE_TextSizePrecise]
- function TControl.RE_TextSizePrecise: Integer;
- var gtlex : TGetTextLengthEx;
- begin
- gtlex.flags := GTL_PRECISE;
- gtlex.codepage := CP_ACP;
- Result := Perform(EM_GETTEXTLENGTHEX,WPARAM(@gtlex), 0 );
- end;
-
- //*
- //[function TControl.REGetNumStyle]
- function TControl.REGetNumStyle: TRichNumbering;
- begin
- Result := TRichNumbering( ReGetParaAttr( 9 shl 16 ) );
- end;
-
- //*
- //[procedure TControl.RESetNumStyle]
- procedure TControl.RESetNumStyle(const Value: TRichNumbering);
- begin
- RESetParaAttr( (9 shl 16) or PFM_NUMBERING, Ord( Value ) );
- end;
-
- //*
- //[function TControl.REGetNumBrackets]
- function TControl.REGetNumBrackets: TRichNumBrackets;
- begin
- REGetParaAttr( 0 );
- Result := TRichNumBrackets( (fREParaFmtRec.wNumberingStyle shr 8) {and 3} );
- end;
-
- //*
- //[procedure TControl.RESetNumBrackets]
- procedure TControl.RESetNumBrackets(const Value: TRichNumBrackets);
- begin
- REGetParaAttr( 0 );
- fREParaFmtRec.wNumberingStyle := fREParaFmtRec.wNumberingStyle and $F8FF
- or Word( Ord( Value ) shl 8 );
- fREParaFmtRec.dwMask := PFM_NUMBERINGSTYLE;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetNumTab]
- function TControl.REGetNumTab: Integer;
- begin
- REGetParaAttr( 0 );
- Result := fREParaFmtRec.wNumberingTab;
- end;
-
- //*
- //[procedure TControl.RESetNumTab]
- procedure TControl.RESetNumTab(const Value: Integer);
- begin
- REGetParaAttr( 0 );
- fREParaFmtRec.wNumberingTab := Value;
- fREParaFmtRec.dwMask := PFM_NUMBERINGTAB;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetNumStart]
- function TControl.REGetNumStart: Integer;
- begin
- REGetParaAttr( 0 );
- Result := fREParaFmtRec.wNumberingStart;
- end;
-
- //*
- //[procedure TControl.RESetNumStart]
- procedure TControl.RESetNumStart(const Value: Integer);
- begin
- REGetParaAttr( 0 );
- fREParaFmtRec.wNumberingStart := Value;
- fREParaFmtRec.dwMask := PFM_NUMBERINGSTART;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetSpacing]
- function TControl.REGetSpacing( const Index: Integer ): Integer;
- begin
- REGetParaAttr( 0 );
- Result := PInteger( cardinal(@fREParaFmtRec.dySpaceBefore) + cardinal(Index and $F) )^;
- end;
-
- //*
- //[procedure TControl.RESetSpacing]
- procedure TControl.RESetSpacing(const Index, Value: Integer);
- begin
- REGetParaAttr( 0 );
- PInteger( cardinal(@fREParaFmtRec.dySpaceBefore) + cardinal(Index and $F) )^ := Value;
- fREParaFmtRec.dwMask := Index and not $F;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetSpacingRule]
- function TControl.REGetSpacingRule: Integer;
- begin
- REGetParaAttr( 0 );
- Result := fREParaFmtRec.bLineSpacingRule;
- end;
-
- //*
- //[procedure TControl.RESetSpacingRule]
- procedure TControl.RESetSpacingRule(const Value: Integer);
- begin
- REGetParaAttr( 0 );
- fREParaFmtRec.bLineSpacingRule := Value;
- fREParaFmtRec.dwMask := PFM_LINESPACING;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetLevel]
- function TControl.REGetLevel: Integer;
- begin
- REGetParaAttr( 0 );
- Result := fREParaFmtRec.bCRC;
- end;
-
- //*
- //[function TControl.REGetBorder]
- function TControl.REGetBorder(Side: TBorderEdge; const Index: Integer): Integer;
- begin
- REGetParaAttr( 0 );
- Result := PWORD( cardinal(@fREParaFmtRec.wBorderSpace) + cardinal(Index) )^ shr (Ord(Side) * 4);
- end;
-
- //*
- //[procedure TControl.RESetBorder]
- procedure TControl.RESetBorder(Side: TBorderEdge; const Index: Integer;
- const Value: Integer);
- var Mask: Word;
- pW : PWord;
- begin
- REGetParaAttr( 0 );
- pw := PWORD( cardinal(@fREParaFmtRec.wBorderSpace) + cardinal(Index) );
- Mask := $F shl (Ord(Side) * 4);
- pw^ := pw^ and not Mask or (Value shl (4 * Ord(Side)) );
- fREParaFmtRec.dwMask := PFM_BORDER;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function TControl.REGetParaEffect]
- function TControl.REGetParaEffect(const Index: Integer): Boolean;
- begin
- Result := LongBool( HiWord( REGetParaAttr( 8 shl 16 ) ) and Index );
- end;
-
- //*
- //[procedure TControl.RESetParaEffect]
- procedure TControl.RESetParaEffect(const Index: Integer;
- const Value: Boolean);
- var Idx: Integer;
- begin
- REGetParaAttr( 0 );
- fREParaFmtRec.wReserved := Index;
- Idx := Index;
- //if Idx >= $4000 then Idx := $4000;
- fREParaFmtRec.dwMask := Idx shl 16;
- RE_ParaFmt := fREParaFmtRec;
- end;
-
- //*
- //[function WndProc_REMonitorIns]
- function WndProc_REMonitorIns( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := False;
- if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_INSERT) and
- ((GetKeyState(VK_CONTROL) or GetKeyState(VK_SHIFT) or GetKeyState(VK_MENU)) >= 0) then
- begin
- if not Self_.fReOvrDisable then
- Self_.fREOvr := not Self_.fREOvr
- else
- Result := True;
- if assigned( Self_.fOnREInsModeChg ) then
- Self_.fOnREInsModeChg( Self_ );
- end;
- end;
-
- //*
- //[function TControl.REGetOverwite]
- function TControl.REGetOverwite: Boolean;
- begin
- AttachProc( WndProc_REMonitorIns );
- Result := fREOvr;
- end;
-
- //*
- //[procedure TControl.RESetOverwrite]
- procedure TControl.RESetOverwrite(const Value: Boolean);
- begin
- if REGetOverwite = Value then // do not replace with fREOvr here!
- Exit; // calling REGetOverwite installs monitor WndProc_REMonitorIns.
- Perform( WM_KEYDOWN, VK_INSERT, 0 );
- Perform( WM_KEYUP, VK_INSERT, 0 );
- end;
-
- //*
- //[procedure TControl.RESetOvrDisable]
- procedure TControl.RESetOvrDisable(const Value: Boolean);
- begin
- REGetOverwite;
- fReOvrDisable := Value;
- end;
-
- //*
- //[function WndProc_RichEdTransp_ParentPaint]
- function WndProc_RichEdTransp_ParentPaint( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var I: Integer;
- C: PControl;
- begin
- if (Msg.message = WM_PAINT) and (Msg.wParam = 0) then
- begin
- for I := 0 to Self_.fChildren.fCount - 1 do
- begin
- C := Self_.fChildren.fItems[ I ];
- if C.fIsCommonControl then
- begin
- Inc( C.fUpdCount );
- PostMessage( C.fHandle, CM_NCUPDATE, C.fUpdCount, WM_PAINT );
- InvalidateRect( C.fHandle, nil, False );
- end;
- end;
- end;
- Result := False;
- end;
-
- //*
- //[function WndProc_RichEdTransp_Update]
- function WndProc_RichEdTransp_Update( Self_:PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Rgn, Rgn1: HRgn;
- R, CR: TRect;
- Pt: TPoint;
- VW, HH, VH, HW: Integer;
- begin
- if Self_.fRETransparent then
- case Msg.message of
- WM_CHAR, WM_KILLFOCUS, WM_SETFOCUS, WM_KEYDOWN:
- begin
- PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
- end;
- WM_PAINT:
- if Msg.wParam = 0 then
- begin
- Inc( Self_.fUpdCount );
- PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
- end;
- WM_SIZE:
- begin
- Inc( Self_.fUpdCount );
- PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
- PostMessage( Self_.fHandle, CM_INVALIDATE, 0, 0 );
- end;
- WM_ERASEBKGND:
- if Msg.wParam = 0 then
- begin
- Inc( Self_.fUpdCount );
- PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
- end;
- WM_HSCROLL, WM_VSCROLL:
- begin
- Self_.fREScrolling := LoWord( Msg.wParam ) <> SB_ENDSCROLL;
- Inc( Self_.fUpdCount );
- PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
- if Self_.fREScrolling then
- Self_.Invalidate;
- end;
- CM_INVALIDATE:
- begin
- //Self_.Update;
- Self_.Parent.Invalidate;
- Self_.Invalidate;
- //Inc( Self_.fUpdCount );
- //PostMessage( Self_.fHandle, CM_NCUPDATE, Self_.fUpdCount, Msg.message );
- end;
- CM_NCUPDATE:
- if Msg.wParam = Self_.fUpdCount then
- begin
- //if Msg.lParam = WM_PAINT then
- // UpdateWindow( Self_.fHandle );
- GetWindowRect( Self_.fHandle, R );
- Windows.GetClientRect( Self_.fHandle, CR );
- Pt.x := 0; Pt.y := 0;
- Pt := Self_.Client2Screen( Pt );
- OffsetRect( CR, Pt.x, Pt.y );
- Rgn := CreateRectRgn( R.Left, R.Top, R.Right, R.Bottom );
- if Self_.fREScrolling then
- begin
- VW := GetSystemMetrics( SM_CXVSCROLL );
- HH := GetSystemMetrics( SM_CYHSCROLL );
- VH := GetSystemMetrics( SM_CYVSCROLL );
- HW := GetSystemMetrics( SM_CXHSCROLL );
- if CR.Right + VW <= R.Right then
- begin
- Rgn1 := CreateRectRgn( CR.Right, CR.Top + VH, CR.Right + VW, CR.Bottom - VH );
- CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
- DeleteObject( Rgn1 );
- end;
- if CR.Bottom + HH <= R.Bottom then
- begin
- Rgn1 := CreateRectRgn( CR.Left + HW, CR.Bottom, CR.Right - HW, CR.Bottom + HH );
- CombineRgn( Rgn, Rgn, Rgn1, RGN_DIFF );
- DeleteObject( Rgn1 );
- end;
- end;
- Self_.Perform( WM_NCPAINT, Rgn, 0 );
- DeleteObject( Rgn ); // Unremarked By M.Gerasimov
- end;
- end;
- Result := False;
- end;
-
- //*
- //[function TControl.REGetTransparent]
- function TControl.REGetTransparent: Boolean;
- begin
- Result := Longbool(ExStyle and WS_EX_TRANSPARENT);
- end;
-
- //*
- //[procedure TControl.RESetTransparent]
- procedure TControl.RESetTransparent(const Value: Boolean);
- begin
- if Value then
- ExStyle := ExStyle or WS_EX_TRANSPARENT
- else
- ExStyle := ExStyle and not WS_EX_TRANSPARENT;
- fRETransparent := Value;
- fParent.AttachProc( WndProc_RichEdTransp_ParentPaint );
- AttachProc( WndProc_RichEdTransp_Update );
- fTransparent := Value;
- end;
-
- //*
- //[procedure TControl.RESetOnURL]
- procedure TControl.RESetOnURL(const Index: Integer; const Value: TOnEvent);
- begin
- if Index = 0 then
- fOnREOverURL := Value
- else
- fOnREURLClick := Value;
- RE_AutoURLDetect := assigned(fOnREOverURL) or assigned(fOnREURLClick);
- end;
-
- //[procedure TControl.SetOnRE_URLClick]
- procedure TControl.SetOnRE_URLClick(const Value: TOnEvent);
- begin
- RESetOnURL( 1, Value );
- end;
-
- procedure TControl.SetOnRE_OverURL(const Value: TOnEvent);
- begin
- RESetOnURL( 0, Value );
- end;
-
- {$IFDEF F_P}
- //[function TControl.REGetOnURL]
- function TControl.REGetOnURL(const Index: Integer): TOnEvent;
- begin
- CASE Index OF
- 0: Result := fOnREOverURL;
- else Result := fOnREURLClick;
- END;
- end;
- {$ENDIF F_P}
-
- //*
- //[function TControl.REGetLangOptions]
- function TControl.REGetLangOptions(const Index: Integer): Boolean;
- begin
- Result := LongBool( Perform( EM_GETLANGOPTIONS, 0, 0 ) and Index);
- end;
-
- //*
- //[procedure TControl.RESetLangOptions]
- procedure TControl.RESetLangOptions(const Index: Integer;
- const Value: Boolean);
- var Mask: Integer;
- begin
- Mask := -1;
- if not Value then Inc( Mask );
- Perform( EM_SETLANGOPTIONS, 0, Perform( EM_GETLANGOPTIONS, 0, 0 ) and
- not Index or (Mask and Index) );
- end;
- {$ENDIF NOT_USE_RICHEDIT}
-
- {$ifdef win32}
- //[function DoTrackMouseEvent]
- function DoTrackMouseEvent(lpEventTrack: PTrackMouseEvent): BOOL;
- var FunTrack: function(lpEventTrack: PTrackMouseEvent): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- ComCtlModule: THandle;
- begin
- Result := FALSE;
- ComCtlModule := GetModuleHandle( cctrl );
- if ComCtlModule = 0 then Exit;
- FunTrack := GetProcAddress( ComCtlModule, '_TrackMouseEvent' );
- if not Assigned( FunTrack ) then Exit;
- Result := FunTrack( lpEventTrack );
- end;
-
- //*
- //[function WndProcMouseEnterLeave]
- function WndProcMouseEnterLeave( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var P: TPoint;
- MouseWasInControl: Boolean;
- Yes: Boolean;
- Track: TTrackMouseEvent;
- begin
- case Msg.message of
- WM_MOUSEFIRST..WM_MOUSELAST:
- begin
- MouseWasInControl := Self_.MouseInControl;
- if Assigned( Self_.fOnTestMouseOver ) then
- Yes := Self_.fOnTestMouseOver( Self_ )
- else
- begin
- GetCursorPos( P );
- P := Self_.Screen2Client( P );
- Yes := PointInRect( P, Self_.ClientRect );
- end;
- if MouseWasInControl <> Yes then
- begin
- //???
- Self_.Invalidate;
- if Yes then
- begin
- Self_.fMouseInControl := TRUE;
- if Assigned( Self_.fOnMouseEnter ) then
- Self_.fOnMouseEnter( Self_ );
- Track.cbSize := Sizeof( Track );
- Track.dwFlags := TME_LEAVE;
- Track.hwndTrack := Self_.Handle;
- //Track.dwHoverTime := 0;
- DoTrackMouseEvent( @ Track );
- //???
- Self_.Invalidate;
- end
- else
- begin
- Self_.fMouseInControl := FALSE;
- Track.cbSize := Sizeof( Track );
- Track.dwFlags := TME_LEAVE or TME_CANCEL;
- Track.hwndTrack := Self_.Handle;
- //Track.dwHoverTime := 0;
- DoTrackMouseEvent( @ Track );
- if Assigned( Self_.fOnMouseLeave ) then
- Self_.fOnMouseLeave( Self_ );
- //???
- Self_.Invalidate; //Erase( FALSE );
- end;
- end;
- end;
- WM_MOUSELEAVE:
- begin
- if Self_.fMouseInControl then
- begin
- Self_.fMouseInControl := FALSE;
- {$IFDEF GRAPHCTL_HOTTRACK}
- if Assigned( Self_.fMouseLeaveProc ) then
- Self_.fMouseLeaveProc( Self_ );
- {$ENDIF}
- if Assigned( Self_.fOnMouseLeave ) then
- Self_.fOnMouseLeave( Self_ );
- //???
- Self_.Invalidate; //Erase( FALSE );
- end;
- end;
- end;
- Result := False;
- end;
- {$endif win32}
-
- //[procedure ProvideMouseEnterLeave]
- procedure ProvideMouseEnterLeave( Self_: PControl );
- begin
- {$ifdef win32}
- InitCommonControls;
- Self_.AttachProc( WndProcMouseEnterLeave );
- //???Self_.InvalidateErase( FALSE );
- {$endif win32}
- end;
-
- //[procedure TControl.SetFlat]
- procedure TControl.SetFlat(const Value: Boolean);
- begin
- //if fFlat = Value then Exit;
- fFlat := Value;
- fMouseInControl := FALSE;
- ProvideMouseEnterLeave( @Self );
- Invalidate;
- end;
-
- //[procedure TControl.SetOnMouseEnter]
- procedure TControl.SetOnMouseEnter(const Value: TOnEvent);
- begin
- fOnMouseEnter := Value;
- ProvideMouseEnterLeave( @Self );
- end;
-
- //[procedure TControl.SetOnMouseLeave]
- procedure TControl.SetOnMouseLeave(const Value: TOnEvent);
- begin
- fOnMouseLeave := Value;
- ProvideMouseEnterLeave( @Self );
- end;
-
- //[procedure TControl.SetOnTestMouseOver]
- procedure TControl.SetOnTestMouseOver(const Value: TOnTestMouseOver);
- begin
- fOnTestMouseOver := Value;
- ProvideMouseEnterLeave( @Self );
- end;
-
- //[function WndProcEdTransparent]
- function WndProcEdTransparent( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- if (Msg.message = WM_KEYDOWN) or
- (Msg.message = WM_MOUSEMOVE) and (GetKeyState( VK_LBUTTON ) < 0) or
- (Msg.message = WM_LBUTTONUP) or (Msg.message = WM_LBUTTONDOWN) then
- Self_.Invalidate;
- Result := False; // continue handling of a message anyway
- end;
-
- //[procedure TControl.EdSetTransparent]
- procedure TControl.EdSetTransparent(const Value: Boolean);
- begin
- Transparent := Value;
- AttachProc( WndProcEdTransparent );
- end;
-
- //[function WndProcSpeedButton]
- var LastHWnd: HWnd; // + Don
- function WndProcSpeedButton( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := False;
- if Msg.message = WM_SETFOCUS then
- begin
- Result := TRUE;
- Rslt := 0;
- LastHWnd := Msg.wParam; // + don
- end
- else // + Don
- if (Msg.message = WM_CAPTURECHANGED) and
- (Msg.lParam = 0) and
- (LastHwnd <> 0) then
- begin
- SetFocus(LastHwnd);
- LastHwnd := 0;
- end;
- end;
-
- //[function TControl.LikeSpeedButton]
- function TControl.LikeSpeedButton: PControl;
- //type TProcObj = procedure of object;
- var Form: PControl;
- begin
- AttachProc( WndProcSpeedButton );
- //fSetFocus := TProcObj( MakeMethod( nil, @ DummyObjProc ) );
- fTabstop := False;
- Style := Style and not WS_TABSTOP;
- Form := ParentForm;
- if Form <> nil then
- if Form.fCurrentControl = @Self then
- begin
- Form.GotoControl( VK_TAB );
- if Form.fCurrentControl = @Self then
- Form.fCurrentControl := nil;
- end;
- Result := @Self;
- end;
-
- { -- Unicode -- }
- //[function TControl.SetUnicode]
- function TControl.SetUnicode(Unicode: Boolean): PControl;
- begin
- {$ifdef win32}
- Perform( CCM_SETUNICODEFORMAT, Integer( Unicode ), 0 );
- {$endif win32}
- Result := @ Self;
- end;
-
- { -- TabControl -- }
-
- //[function TControl.GetPages]
- function TControl.GetPages(Idx: Integer): PControl;
- var Item: TTCItem;
- begin
- Item.mask := TCIF_PARAM;
- if Perform( TCM_GETITEM, Idx, Integer( @Item ) ) = 0 then
- Result := nil
- else
- Result := Pointer( Item.lParam );
- end;
-
- //[function TControl.TCGetItemText]
- function TControl.TCGetItemText(Idx: Integer): KOLString;
- var TI: TTCItem;
- Buffer: array[ 0..1023 ] of KOLChar;
- begin
- TI.mask := TCIF_TEXT;
- TI.pszText := @Buffer[ 0 ];
- TI.cchTextMax := sizeof( Buffer );
- Buffer[ 0 ] := #0;
- Perform( TCM_GETITEM, Idx, Integer( @TI ) );
- Result := PKOLChar( @ Buffer[ 0 ] );
- end;
-
- //[procedure TControl.TCSetItemText]
- procedure TControl.TCSetItemText(Idx: Integer; const Value: KOLString);
- var TI: TTCItem;
- begin
- TI.mask := TCIF_TEXT;
- TI.pszText := PKOLChar( Value );
- Perform( TCM_SETITEM, Idx, Integer( @TI ) );
- end;
-
- //[function TControl.TCGetItemImgIDx]
- function TControl.TCGetItemImgIDx(Idx: Integer): Integer;
- var TI: TTCItem;
- begin
- TI.mask := TCIF_IMAGE;
- if Perform( TCM_GETITEM, Idx, Integer( @TI ) ) = 0 then
- Result := -1
- else
- Result := TI.iImage;
- end;
-
- //[procedure TControl.TCSetItemImgIdx]
- procedure TControl.TCSetItemImgIdx(Idx: Integer; const Value: Integer);
- var TI: TTCItem;
- begin
- TI.mask := TCIF_IMAGE;
- TI.iImage := Value;
- Perform( TCM_SETITEM, Idx, Integer( @TI ) );
- end;
-
- //[function TControl.TCGetItemRect]
- function TControl.TCGetItemRect(Idx: Integer): TRect;
- begin
- if Perform( TCM_GETITEMRECT, Idx, Integer( @Result ) ) = 0 then
- begin
- Result.Left := 0;
- Result.Right := 0;
- Result.Top := 0;
- Result.Bottom := 0;
- end;
- end;
-
- //[procedure TControl.TC_SetPadding]
- procedure TControl.TC_SetPadding(cx, cy: Integer);
- begin
- Perform( TCM_SETPADDING, 0, cx or (cy shl 16) );
- end;
-
- //[function TControl.TC_TabAtPos]
- function TControl.TC_TabAtPos(x, y: Integer): Integer;
- type TTCHittestInfo = {$ifndef wince}packed{$endif} record
- Pt: TPoint;
- Fl: DWORD;
- end;
- var HTI: TTCHitTestInfo;
- begin
- HTI.Pt.x := x;
- HTI.Pt.y := y;
- Result := Perform( TCM_HITTEST, 0, Integer( @HTI ) );
- end;
-
- //[function TControl.TC_DisplayRect]
- function TControl.TC_DisplayRect: TRect;
- begin
- Windows.GetClientRect( fHandle, Result );
- Perform( TCM_ADJUSTRECT, 0, Integer( @Result ) );
- {$ifdef wince}
- Dec(Result.Top, 2);
- Dec(Result.Left, 2);
- Inc(Result.Right, 2);
- {$endif wince}
- end;
-
- //[function TControl.TC_IndexOf]
- function TControl.TC_IndexOf(const S: KOLString): Integer;
- begin
- Result := TC_SearchFor( S, -1, FALSE );
- end;
-
- //[function TControl.TC_SearchFor]
- function TControl.TC_SearchFor(const S: KOLString; StartAfter: Integer;
- Partial: Boolean): Integer;
- var I: Integer;
- begin
- Result := -1;
- for I := StartAfter+1 to Count-1 do
- begin
- if Partial and ( Copy( TC_Items[ I ], 1, Length( S ) ) = S ) or
- ( TC_Items[ I ] = S ) then
- begin
- Result := I;
- break;
- end;
- end;
- end;
-
- //[function TControl.TC_Insert]
- function TControl.TC_Insert(Idx: Integer; const TabText: KOLString;
- TabImgIdx: Integer): PControl;
- var TI: TTCItem;
- begin
- Result := NewPanel( @Self, esNone );
- {$IFDEF OLD_ALIGN}
- Result.FAlign := caClient; //+ Galkov
- Result.fNotUseAlign := True;
- Result.fVisibleWoParent := TRUE;
- {$ELSE NEW_ALIGN}
- Result.Align := caClient; //+ Galkov
- {$ENDIF}
- Result.Visible := CurIndex<0;
- TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;
- TI.iImage := TabImgIdx;
- TI.pszText := PKOLChar( TabText );
- TI.lParam := Integer( Result );
- Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
- {$IFDEF OLD_ALIGN}
- Result.BoundsRect := TC_DisplayRect;//+ Galkov
- {$ENDIF}
- Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- Result.fClassicTransparent := Result.fTransparent;
- Attach_WM_THEMECHANGED(Result);
- XP_Themes_For_TabPanel(Result);
- {$ENDIF}
- end;
-
- //[procedure TControl.TC_Delete]
- procedure TControl.TC_Delete(Idx: Integer);
- var Page: PControl;
- begin
- Page := TC_Pages[ Idx ];
- if Page = nil then Exit;
- Perform( TCM_DELETEITEM, Idx, 0 );
- Page.Free;
- Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
- end;
-
- {$IFNDEF OLD_ALIGN}
- //[procedure TControl.TC_InsertControl
- procedure TControl.TC_InsertControl( Idx: Integer; const TabText: KOLString;
- TabImgIdx: Integer; Page: PControl);
- var TI: TTCItem;
- begin
- Page.Visible := CurIndex<0;
- TI.mask := TCIF_TEXT or TCIF_IMAGE or TCIF_PARAM;
- TI.iImage := TabImgIdx;
- TI.pszText := PKOLChar( TabText );
- TI.lParam := Integer( Page );
- Perform( TCM_INSERTITEM, Idx, Integer( @TI ) );
- Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
- end;
-
- //[function TControl.TC_Remove]
- function TControl.TC_Remove( Idx: Integer ):PControl;
- begin
- Result := TC_Pages[ Idx ];
- if Result = nil then Exit;
- Perform( TCM_DELETEITEM, Idx, 0 );
- Perform(WM_SIZE,0,0); //May be changes of margins for TabControl
- end;
- {$ENDIF}
-
- { -- TreeView -- }
-
- //[function TControl.TVGetItemIdx]
- function TControl.TVGetItemIdx(const Index: Integer): THandle;
- begin
- Result := Perform( TVM_GETNEXTITEM, Index, 0 );
- end;
-
- //[procedure TControl.TVSetItemIdx]
- procedure TControl.TVSetItemIdx(const Index: Integer;
- const Value: THandle);
- begin
- Perform( TVM_SELECTITEM, Index, Value );
- end;
-
- //[function TControl.TVGetItemNext]
- function TControl.TVGetItemNext(Item: THandle; const Index: Integer): THandle;
- begin
- Result := Perform( TVM_GETNEXTITEM, Index, Item );
- end;
-
- //[function TControl.TVGetItemRect]
- function TControl.TVGetItemRect(Item: THandle; TextOnly: Boolean): TRect;
- begin
- Result.Left := Item;
- if Perform( TVM_GETITEMRECT, Integer( TextOnly ), Integer( @Result ) ) = 0 then
- begin
- Result.Left := 0;
- Result.Right := 0;
- Result.Top := 0;
- Result.Bottom := 0;
- end;
- end;
-
- //[function TControl.TVGetItemVisible]
- function TControl.TVGetItemVisible(Item: THandle): Boolean;
- var R: TRect;
- begin
- R := TVItemRect[ Item, False ];
- Result := R.Bottom > R.Top;
- end;
-
- //[procedure TControl.TVSetItemVisible]
- procedure TControl.TVSetItemVisible(Item: THandle; const Value: Boolean);
- begin
- if Value then
- Perform( TVM_ENSUREVISIBLE, 0, Item );
- end;
-
- //[function TControl.TVGetItemStateFlg]
- function TControl.TVGetItemStateFlg(Item: THandle; const Index: Integer): Boolean;
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_STATE;
- TVI.hItem := Item;
- TVI.stateMask := Index;
- Result := False;
- if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
- Result := (TVI.state and Index) <> 0;
- end;
-
- //[procedure TControl.TVSetItemStateFlg]
- procedure TControl.TVSetItemStateFlg(Item: THandle; const Index: Integer;
- const Value: Boolean);
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_STATE;
- TVI.hItem := Item;
- TVI.stateMask := Index;
- TVI.state := $FFFFFFFF and Index;
- if not Value then
- TVI.state := 0;
- Perform( TVM_SETITEM, 0, Integer( @TVI ) );
- end;
-
- //[function TControl.TVGetItemImage]
- function TControl.TVGetItemImage(Item: THandle; const Index: Integer): Integer;
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or Loword( Index );
- TVI.hItem := Item;
- if Hiword( Index ) <> 0 then
- begin
- TVI.mask := TVIF_STATE or TVIF_HANDLE;
- TVI.stateMask := Loword( Index );
- end;
- Result := -1;
- if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
- begin
- if Hiword( Index ) <> 0 then
- Result := (TVI.state shr Hiword( Index )) and $F
- else
- if Loword( Index ) = TVIF_IMAGE then
- Result := TVI.iImage
- else
- Result := TVI.iSelectedImage;
- end;
- end;
-
- //[procedure TControl.TVSetItemImage]
- procedure TControl.TVSetItemImage(Item: THandle; const Index: Integer;
- const Value: Integer);
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or Loword( Index );
- TVI.hItem := Item;
- TVI.iImage := Value;
- TVI.iSelectedImage := Value;
- if Hiword( Index ) <> 0 then
- begin
- TVI.mask := TVIF_STATE or TVIF_HANDLE;
- TVI.stateMask := Loword( Index );
- TVI.state := Value shl Hiword( Index );
- end;
- Perform( TVM_SETITEM, 0, Integer( @TVI ) );
- end;
-
- //[function TControl.TVGetItemText]
- function TControl.TVGetItemText(Item: THandle): KOLString;
- var TVI: TTVItem;
- Buffer: array[ 0..4095 ] of KOLChar;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_TEXT;
- TVI.hItem := Item;
- TVI.pszText := @Buffer[ 0 ];
- Buffer[ 0 ] := #0;
- TVI.cchTextMax := Sizeof( Buffer ) {$IFDEF UNICODE_CTRLS} div Sizeof( KOLChar ) {$ENDIF};
- Perform( TVM_GETITEM, 0, Integer( @TVI ) );
- Result := PKOLChar( @ Buffer[ 0 ] );
- end;
-
- //[procedure TControl.TVSetItemText]
- procedure TControl.TVSetItemText(Item: THandle; const Value: KOLString);
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_TEXT;
- TVI.hItem := Item;
- TVI.pszText := PKOLChar( Value );
- Perform( TVM_SETITEM, 0, Integer( @TVI ) );
- end;
-
- //[function TControl.TVItemPath]
- function TControl.TVItemPath(Item: THandle; Delimiter: KOLChar): KOLString;
- begin
- if Item = 0 then
- Item := TVSelected;
- Result := '';
- while Item <> 0 do
- begin
- if Result <> '' then
- Result := Delimiter + Result;
- Result := TVItemText[ Item ] + Result;
- Item := TVItemParent[ Item ];
- end;
- end;
-
- //[function TControl.TV_GetItemHasChildren]
- function TControl.TV_GetItemHasChildren(Item: THandle): Boolean;
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
- TVI.hItem := Item;
- Perform( TVM_GETITEM, 0, Integer( @TVI ) );
- Result := TVI.cChildren = 1;
- end;
-
- //[procedure TControl.TV_GetItemChildCount]
- function TControl.TV_GetItemChildCount(Item: THandle): Integer;
- var Node: THandle;
- begin
- Result := 0;
- Node := TVItemChild[ Item ];
- while Node <> 0 do
- begin
- Inc( Result );
- Node := TVItemNext[ Node ];
- end;
- end;
-
- //[procedure TControl.TV_SetItemHasChildren]
- procedure TControl.TV_SetItemHasChildren(Item: THandle;
- const Value: Boolean);
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_CHILDREN;
- TVI.hItem := Item;
- TVI.cChildren := 1 and Integer( Value );
- Perform( TVM_SETITEM, 0, Integer( @TVI ) );
- end;
-
- //[function TControl.TVItemAtPos]
- function TControl.TVItemAtPos(x, y: Integer; var Where: DWORD): THandle;
- var HTI: TTVHitTestInfo;
- begin
- HTI.pt.x := x;
- HTI.pt.y := y;
- Result := Perform( TVM_HITTEST, 0, Integer( @HTI ) );
- Where := HTI.{$ifdef wince}flags{$else}fl{$endif};
- end;
-
- type
- TTVInsertStruct = {$ifndef wince}packed{$endif} Record
- hParent: THandle;
- hAfter : THandle;
- item: TTVItem;
- end;
- {$ifdef win32}
- TTVInsertStructEx = {$ifndef wince}packed{$endif} Record
- hParent: THandle;
- hAfter : THandle;
- item: TTVItemEx;
- end;
- {$endif win32}
-
- //[function TControl.TVInsert]
- function TControl.TVInsert(nParent, nAfter: THandle;
- const Txt: KOLString): THandle;
- var TVIns: TTVInsertStruct;
- begin
- TVIns.hParent := nParent;
- TVIns.hAfter := nAfter;
- TVIns.item.mask := TVIF_TEXT;
- TVIns.item.pszText := PKOLChar( Txt );
- Result := Perform( TVM_INSERTITEM, 0, Integer( @TVIns ) );
- Invalidate;
- end;
-
- //[procedure TControl.TVExpand]
- procedure TControl.TVExpand(Item: THandle; Flags: DWORD);
- begin
- Perform( TVM_EXPAND, Flags, Item );
- end;
-
- //[procedure TControl.TVSort]
- procedure TControl.TVSort( N: THandle );
- var a: Cardinal;
- b: Boolean;
- begin
- b := N = 0;
- if b then
- begin
- N := TVRoot;
- end;
- while N <> 0 do
- begin
- a := TVItemChild[N];
- if a > 0 then
- TVSort(a);
- Perform(TVM_SORTCHILDREN, 0, N);
- N := TVItemNext[N];
- end;
- if b then //moved by Tr"]f
- Perform(TVM_SORTCHILDREN, 0, 0); //+ by YS
- end;
-
- //[procedure TControl.TVDelete]
- procedure TControl.TVDelete(Item: THandle);
- begin
- Perform( TVM_DELETEITEM, 0, Item );
- Invalidate;
- end;
-
- //[function TControl.TVGetItemData]
- function TControl.TVGetItemData(Item: THandle): Pointer;
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_PARAM;
- TVI.hItem := Item;
- Result := nil;
- if Perform( TVM_GETITEM, 0, Integer( @TVI ) ) <> 0 then
- Result := Pointer( TVI.lParam );
- end;
-
- //[procedure TControl.TVSetItemData]
- procedure TControl.TVSetItemData(Item: THandle; const Value: Pointer);
- var TVI: TTVItem;
- begin
- TVI.mask := TVIF_HANDLE or TVIF_PARAM;
- TVI.hItem := Item;
- TVI.lParam := Integer( Value );
- Perform( TVM_SETITEM, 0, Integer( @TVI ) );
- end;
-
- //[procedure TControl.TVEditItem]
- procedure TControl.TVEditItem(Item: THandle);
- begin
- Perform( TVM_EDITLABEL, 0, Item );
- end;
-
- //[procedure TControl.TVStopEdit]
- procedure TControl.TVStopEdit(Cancel: Boolean);
- begin
- Perform( TVM_ENDEDITLABELNOW, Integer( Cancel ), 0 );
- end;
-
- //[function WndProcTVRightClickSelect]
- function WndProcTVRightClickSelect( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
- var I: Integer;
- Where: DWORD;
- begin
- if Msg.message = WM_RBUTTONDOWN then
- begin
- I := Sender.TVItemAtPos( SmallInt( Msg.lParam and $FFFF ),
- SmallInt( Msg.lParam shr 16 ), Where );
- if I <> 0 then
- Sender.TVSelected := I;
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.SetTVRightClickSelect]
- procedure TControl.SetTVRightClickSelect(const Value: Boolean);
- begin
- fTVRightClickSelect := Value;
- if Value then
- AttachProc( @WndProcTVRightClickSelect );
- end;
-
- //[procedure TControl.SetOnTVDelete]
- procedure TControl.SetOnTVDelete( const Value: TOnTVDelete );
- begin
- fOnTVDelete := Value;
- if fParent <> nil then
- begin
- fParent.Add2AutoFreeEx( Clear );
- fParent.DetachProc( WndProcNotify );
- fParent.AttachProcEx( WndProcNotify, TRUE );
- end;
- AttachProcEx( ProcTVDeleteItem, TRUE );
- end;
-
- //[function ClipboardHasText]
- function ClipboardHasText: Boolean;
- begin
- Result := false;
- if OpenClipboard( 0 ) then
- begin
- if IsClipboardFormatAvailable( CF_TEXT ) then
- Result := TRUE;
- CloseClipboard;
- end;
- end;
-
- //[function Clipboard2Text]
- {$ifdef wince}
- function Clipboard2Text: String;
- begin
- Result:=Clipboard2WText;
- end;
- {$else}
- function Clipboard2Text: String;
- var gbl: THandle;
- str: PChar;
- begin
- Result := '';
- if OpenClipboard( 0 ) then
- begin
- if IsClipboardFormatAvailable( CF_TEXT ) then
- begin
- gbl := GetClipboardData( CF_TEXT );
- if gbl <> 0 then
- begin
- str := GlobalLock( gbl );
- if str <> nil then
- begin
- Result := str;
- GlobalUnlock( gbl );
- end;
- end;
- end;
- CloseClipboard;
- end;
- end;
- {$endif wince}
-
- {-}
- {$IFNDEF _D2}
- //[function Clipboard2WText]
- function Clipboard2WText: WideString;
- var gbl: THandle;
- str: PWideChar;
- begin
- Result := '';
- if OpenClipboard( 0 ) then
- begin
- if IsClipboardFormatAvailable( CF_UNICODETEXT ) then
- begin
- gbl := GetClipboardData( CF_UNICODETEXT );
- if gbl <> 0 then
- begin
- str := GlobalLock( gbl );
- if str <> nil then
- begin
- Result := str;
- GlobalUnlock( gbl );
- end;
- end;
- end;
- CloseClipboard;
- end;
- end;
- {$ENDIF}
-
- {+}
- //[function Text2Clipboard]
- {$ifdef wince}
- function Text2Clipboard( const S: String ): Boolean;
- begin
- Result:=WText2Clipboard(S);
- end;
- {$else}
- function Text2Clipboard( const S: String ): Boolean;
- var gbl: THandle;
- str: PChar;
- begin
- Result := False;
- if not OpenClipboard( 0 ) then Exit;
- EmptyClipboard;
- if S <> '' then
- begin
- gbl := GlobalAlloc( GMEM_MOVEABLE, Length( S ) + 1 );
- if gbl <> 0 then
- begin
- str := GlobalLock( gbl );
- Move( S[ 1 ], str^, Length( S ) + 1 );
- GlobalUnlock( gbl );
- Result := SetClipboardData( CF_TEXT, gbl ) <> 0;
- end;
- end
- else
- Result := True;
- CloseClipboard;
- end;
- {$endif wince}
-
- {-}
- {$IFNDEF _D2}
- //[function WText2Clipboard]
- function WText2Clipboard( const WS: WideString ): Boolean;
- var gbl: THandle;
- str: PChar;
- begin
- Result := False;
- if not OpenClipboard( 0 ) then Exit;
- EmptyClipboard;
- if WS <> '' then
- begin
- gbl := GlobalAlloc( GMEM_MOVEABLE, (Length( WS ) + 1) * 2 );
- if gbl <> 0 then
- begin
- str := GlobalLock( gbl );
- Move( WS[ 1 ], str^, (Length( WS ) + 1) * 2 );
- GlobalUnlock( gbl );
- Result := SetClipboardData( CF_UNICODETEXT, gbl ) <> 0;
- end;
- end
- else
- Result := True;
- CloseClipboard;
- end;
- {$ENDIF}
-
- {+}
- //[function TControl.Size]
- function TControl.Size(W, H: Integer): PControl;
- var C, P: PControl;
- dW, dH: Integer;
- begin
- C := @Self;
- while True do
- begin
- dW := 0; dH := 0;
- P := C.FParent;
- if C.ToBeVisible {or C.fCreateHidden or (P <> nil) and (P.fVisible)} then
- begin
- if C.fAlign in [caLeft, caRight, caClient] then
- begin
- if H > 0 then
- begin
- dH := H - C.Height; H := 0;
- end;
- end;
- if C.fAlign in [caTop, caBottom, caClient] then
- begin
- if W > 0 then
- begin
- dW := W - C.Width; W := 0;
- end;
- end;
- end;
- if (W > 0) or (H > 0) then
- begin
- C.SetSize( W, H );
- if (P <> nil) // {Ralf Junker}
- and not P.IsApplet then
- C.ResizeParent;
- end;
- if (dW = 0) and (dH = 0) then break;
- C := P; //C.FParent;
- if C = nil then break;
- //if not C.fIsControl then break;
- if C.IsApplet then break;
- W := C.Width + dW;
- H := C.Height + dH;
- end;
- Result := @Self;
- end;
- {$ENDIF WIN_GDI}
-
- //[procedure AutoSzProc]
- {$IFDEF GDI}
- procedure AutoSzProc( Self_: PObj );
- var DeltaX, DeltaY: Integer;
- SZ: TSize; PT: TPoint;
- Txt: KOLString;
- Chg: Boolean;
- R: TRect;
- Flags: DWORD;
- {+ecm}
- OldFont: HFONT;
- CtlHavingFont: PControl;
- {/+ecm}
- OldNotUseAlign: boolean;
- begin
- Txt := PControl( Self_ ).fCaption;
- SZ.cx := 0;
- SZ.cy := 0;
- if Txt <> '' then
- begin
- if not PControl( Self_ ).HandleAllocated then begin
- PControl( Self_ ).fAutoSize:=DummyObjProc;
- PControl( Self_ ).GetWindowHandle; // this line must be here.
- //-- otherwise, when handle is not yet allocated,
- // it is requested in TCanvas.GetHandle, and in result
- // of unpredictable recursion some memory can be currupted.
- PControl( Self_ ).fAutoSize:=AutoSzProc;
- end;
- if Assigned( PControl( Self_ ).fFont ) then
- if PControl( Self_ ).fFont.fData.Font.Italic then
- Txt := Txt + ' ';
- if PControl( Self_ ).fWordWrap and (PControl( Self_ ).fAlign <> caClient) then
- begin
- R := PControl( Self_ ).ClientRect;
- Dec(R.Right, PControl( Self_ ).fCommandActions.aAutoSzX);
- if R.Right < R.Left then
- R.Right:=R.Left + 1;
- Flags := DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK;
- CASE PControl( Self_ ).fTextAlign OF
- taCenter: Flags := Flags or DT_CENTER;
- taRight : Flags := Flags or DT_RIGHT;
- END;
- {-ecm}
- // CASE Self_.fVerticalAlign OF
- // vaCenter: Flags := Flags or DT_VCENTER;
- // vaBottom: Flags := Flags or DT_BOTTOM;
- // END;
- {/-ecm}
- {+ecm}
- CtlHavingFont := PControl( Self_ );
- while (CtlHavingFont <> nil) and not Assigned( CtlHavingFont.FFont ) do
- CtlHavingFont := CtlHavingFont.Parent;
- OldFont := 0;
- if Assigned( CtlHavingFont ) then
- OldFont := SelectObject( PControl( Self_ ).Canvas.Handle, CtlHavingFont.Font.Handle );
- {/+ecm}
- // DrawText return the height of the text !
- SZ.cy := DrawText( PControl( Self_ ).Canvas.Handle, PKOLChar( Txt ), Length( Txt ), R, Flags );
- {+ecm}
- if Assigned( CtlHavingFont ) then
- SelectObject(PControl( Self_ ).Canvas.fHandle,OldFont);
- {/+ecm}
- SZ.cx := R.Right - R.Left;
- {$ifdef wince}
- Inc(SZ.cx);
- {$endif wince}
- //SZ.cy := R.Bottom - R.Top;
- end
- else
- PControl( Self_ ).Canvas.TextArea( Txt, SZ, PT );
- end;
- Chg := FALSE;
- OldNotUseAlign:=PControl( Self_ ).fNotUseAlign;
- PControl( Self_ ).fNotUseAlign:=True;
- if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then
- begin
- DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX;
- if PControl( Self_ ).Width <> SZ.cx + DeltaX then
- begin
- PControl( Self_ ).Width := SZ.cx + DeltaX;
- Chg := TRUE;
- end;
- if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then
- begin
- PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
- Chg := TRUE;
- end;
- end;
- if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then
- begin
- DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY;
- if PControl( Self_ ).Height <> SZ.cy + DeltaY then
- begin
- PControl( Self_ ).Height := SZ.cy + DeltaY;
- Chg := TRUE;
- end;
- if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then
- begin
- PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
- Chg := TRUE;
- end;
- end;
- PControl( Self_ ).fNotUseAlign:=OldNotUseAlign;
- if Chg then
- begin
- {$IFDEF OLD_ALIGN}
- if PControl( Self_ ).fParent <> nil then
- Global_Align( PControl( Self_ ).fParent );
- {$ENDIF}
- Global_Align( Self_ );
- end;
- end;
- {$ENDIF GDI}
- {$IFDEF _X_}
- {$IFDEF GTK}
- procedure AutoSzProc( Self_: PObj );
- var SZ: TSize;
- //Txt: KOLString;
- Chg: Boolean;
- req_captn, req_evbox: TGtkRequisition;
- begin
- //Txt := PControl( Self_ ).fCaption;
- SZ.cx := 0;
- SZ.cy := 0;
- //if Txt <> '' then
- begin
- {if Assigned( PControl( Self_ ).fFont ) then
- if PControl( Self_ ).fFont.fData.Font.Italic then
- Txt := Txt + ' ';}
- gtk_widget_size_request( PControl( Self_ ).fCaptionHandle, @ req_captn );
- //gtk_widget_get_size_request( PControl( Self_ ).fCaptionHandle, @ Sz.cx, @ Sz.cy );
- //gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ requisition2 );
- {if Sz.cx < 0 then Sz.cx := PControl( Self_ ).Width;
- if Sz.cy < 0 then Sz.cy := PControl( Self_ ).Height;
- Sz.cx := max( requisition2.width, requisition1.width + requisition2.width - Sz.cx );
- Sz.cy := max( requisition2.height, requisition1.height + requisition2.height - Sz.cy );}
- if (PControl( Self_ ).fDeltaX = 0) and
- (PControl( Self_ ).fDeltaY = 0) then
- begin
- gtk_widget_size_request( PControl( Self_ ).fEventboxHandle, @ req_evbox );
- PControl( Self_ ).fDeltaX := Max( 0, req_evbox.width - req_captn.width );
- PControl( Self_ ).fDeltaY := Max( 0, req_evbox.height - req_captn.height );
- end;
- Sz.cx := req_captn.width + PControl( Self_ ).fDeltaX;
- Sz.cy := req_captn.height + PControl( Self_ ).fDeltaY;
- //gtk_widget_get_size_request( PControl( Self_ ).fHandle, @ Sz.cx, @ Sz.cy );
- end;
- Chg := FALSE;
- if PControl( Self_ ).FAlign in [ caNone, caLeft, caRight ] then
- begin
- //DeltaX := PControl( Self_ ).fCommandActions.aAutoSzX;
- if PControl( Self_ ).Width <> SZ.cx {+ DeltaX} then
- begin
- PControl( Self_ ).Width := SZ.cx {+ DeltaX};
- Chg := TRUE;
- end;
- if PControl( Self_ ).fMinWidth > PControl( Self_ ).Width then
- begin
- PControl( Self_ ).Width := PControl( Self_ ).fMinWidth;
- Chg := TRUE;
- end;
- end;
- if PControl( Self_ ).FAlign in [ caNone, caTop, caBottom ] then
- begin
- //DeltaY := PControl( Self_ ).fCommandActions.aAutoSzY;
- if PControl( Self_ ).Height <> SZ.cy {+ DeltaY} then
- begin
- PControl( Self_ ).Height := SZ.cy {+ DeltaY};
- Chg := TRUE;
- end;
- if PControl( Self_ ).FMinHeight > PControl( Self_ ).Height then
- begin
- PControl( Self_ ).Height := PControl( Self_ ).FMinHeight;
- Chg := TRUE;
- end;
- end;
- if Chg then
- begin
- {$IFDEF OLD_ALIGN}
- if PControl( Self_ ).fParent <> nil then
- Global_Align( PControl( Self_ ).fParent );
- {$ENDIF}
- Global_Align( Self_ );
- end;
- end;
- {$ENDIF GTK}
- {$ENDIF _X_}
-
- //[function TControl.AutoSize]
- function TControl.AutoSize(AutoSzOn: Boolean): PControl;
- begin
- if AutoSzOn then
- begin
- fAutoSize := AutoSzProc;
- DoAutoSize;
- end
- else
- fAutoSize := DummyObjProc;
- Result := @Self;
- end;
-
- {$IFDEF WIN_GDI}
- //[function TControl.IsAutoSize]
- function TControl.IsAutoSize: Boolean;
- begin
- Result := Assigned( fAutoSize );
- end;
-
- //*
- //[function TControl.GetToBeVisible]
- function TControl.GetToBeVisible: Boolean;
- begin
- Result := fVisible or fCreateHidden or fVisibleWoParent;
- if fIsControl then
- if Parent <> nil then
- begin
- if fVisibleWoParent then
- Result := fVisible
- else
- begin
- Parent.Visible; // needed to provide correct fVisible for a form!
- Result := Result and Parent.ToBeVisible;
- end;
- end;
- end;
-
- ///////////////////////////////////////////////////////////////////////
- // W I N D O W S
- ///////////////////////////////////////////////////////////////////////
-
- { -- Set of window-related utility functions. -- }
- type
- PGUIThreadInfo = ^TGUIThreadInfo;
- tagGUITHREADINFO = {$ifndef wince}packed{$endif} record
- cbSize: DWORD;
- flags: DWORD;
- hwndActive: HWND;
- hwndFocus: HWND;
- hwndCapture: HWND;
- hwndMenuOwner: HWND;
- hwndMoveSize: HWND;
- hwndCaret: HWND;
- rcCaret: TRect;
- end;
- TGUIThreadInfo = tagGUITHREADINFO;
-
- const
- GUI_CARETBLINKING = $00000001;
- GUI_INMOVESIZE = $00000002;
- GUI_INMENUMODE = $00000004;
- GUI_SYSTEMMENUMODE = $00000008;
- GUI_POPUPMENUMODE = $00000010;
-
- type TGUIThreadInfo_Proc = function( ThreadID: THandle; var GTI: TGUIThreadInfo )
- : Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
-
- var Proc_GetGUIThreadInfo: TGuiThreadInfo_Proc;
-
- //[function GetWindowChild]
- function GetWindowChild( Wnd: HWnd; Kind: TWindowChildKind ): HWnd;
- var GTI: TGuiThreadInfo;
- ThreadID: THandle;
- Module: THandle;
- begin
- if not Assigned( Proc_GetGUIThreadInfo ) then
- begin
- Module := GetModuleHandle( 'User32' );
- Proc_GetGUIThreadInfo := GetProcAddress( Module, 'GetGUIThreadInfoA' );
- if not Assigned( Proc_GetGUIThreadInfo ) then
- Proc_GetGUIThreadInfo := Pointer( -1 );
- end;
- Result := Wnd;
- if @Proc_GetGUIThreadInfo = Pointer( -1 ) then
- Exit;
- Result := 0;
- if Wnd = 0 then
- ThreadID := GetCurrentThreadID
- else
- ThreadID := GetWindowThreadProcessID( Wnd, nil );
- if ThreadID = 0 then Exit;
- GTI.cbSize := Sizeof( GTI );
- if Proc_GetGUIThreadInfo( ThreadId, GTI ) then
- begin
- case Kind of
- wcActive: Result := GTI.hwndActive;
- wcFocus: Result := GTI.hwndFocus;
- wcCapture: Result := GTI.hwndCapture;
- wcMenuOwner: Result := GTI.hwndMenuOwner;
- wcMoveSize: Result := GTI.hwndMoveSize;
- wcCaret: Result := GTI.hwndCaret;
- end;
- end;
- end;
-
- {$ifdef win32}
- //[function GetFocusedChild]
- function GetFocusedChild( Wnd: HWnd ): HWnd;
- var Tr1, Tr2: THandle;
- begin
- Result := 0;
- Tr1 := GetCurrentThreadId;
- Tr2 := GetWindowThreadProcessId( Wnd, nil );
- if Tr1 = Tr2 then
- Result := GetFocus
- else
- if AttachThreadInput( Tr2, Tr1, True ) then
- begin
- Result := GetFocus;
- AttachThreadInput( Tr2, Tr1, False );
- end;
- end;
-
- //[function WaitFocusedWndChild]
- function WaitFocusedWndChild( Wnd: HWnd ): HWnd;
- var T1, T2: Integer;
- W: HWnd;
- begin
- Sleep( 50 );
- T1 := GetTickCount;
- while True do
- begin
- W := GetTopWindow( Wnd );
- if W = 0 then W := Wnd;
- W := GetFocusedChild( W );
- if W <> 0 then
- begin
- Wnd := W;
- break;
- end;
- T2 := GetTickCount;
- if Abs( T1 - T2 ) > 100 then break;
- end;
- Result := Wnd;
- end;
-
- //[function Stroke2Window]
- function Stroke2Window( Wnd: HWnd; const S: String ): Boolean;
- var P: PChar;
- begin
- Result := False;
- //Wnd := GetTopWindow( Wnd );
- Wnd := WaitFocusedWndChild( Wnd );
- if Wnd = 0 then Exit;
- P := PChar( S );
- while P^ <> #0 do
- begin
- PostMessage( Wnd, WM_CHAR, Integer( P^ ), 1 );
- Inc( P );
- end;
- Result := True;
- end;
-
- //[function Stroke2WindowEx]
- function Stroke2WindowEx( Wnd: HWnd; const S: String; Wait: Boolean ): Boolean;
- var P: PChar;
- EndChar: Char;
- MsgDn, MsgUp, SCA: Integer;
-
- function Compare( Pattern: PChar ): Boolean;
- var Pos: PChar;
- C1, C2: Char;
- begin
- Pos := P;
- while Pattern^ <> #0 do
- begin
- C1 := Pattern^;
- C2 := Pos^;
- if C1 in [ 'a'..'z' ] then
- C1 := Char( Ord( C1 ) - $20 );
- if C2 in [ 'a'..'z' ] then
- C2 := Char( Ord( C2 ) - $20 );
- if C1 <> C2 then
- begin
- Result := False;
- Exit;
- end;
- Inc( Pos );
- Inc( Pattern );
- end;
- while Pos^ = ' ' do Inc( Pos );
- P := Pos;
- Result := True;
- end;
-
- procedure Send( Msg, KeyCode: Integer );
- var lParam: Integer;
- begin
- Wnd := WaitFocusedWndChild( Wnd );
- if Wnd = 0 then Exit;
- lParam := 1;
- if longBool( SCA and 4 ) then
- lParam := $20000001;
- if Msg = MsgUp then
- lParam := lParam or Integer($D0000000);
- PostMessage( Wnd, Msg, KeyCode, lParam );
- Applet.ProcessMessages;
- if Wait then
- Sleep( 50 );
- end;
-
- function CompareSend( Pattern: PChar; Value2Send: Integer ): Boolean;
- begin
- if Compare( Pattern ) then
- begin
- Send( MsgDn, Value2Send );
- Send( MsgUp, Value2Send );
- Result := True;
- end
- else
- Result := False;
- end;
-
- function ParseKeys( EndChar: Char ): PChar;
- var FN: Integer;
- begin
- SCA := 0;
- while not (P^ in [ #0, EndChar ]) do
- begin
- if Compare( 'Shift' ) then SCA := SCA or 1
- else
- if Compare( 'Ctrl' ) then SCA := SCA or 2
- else
- if Compare( 'Alt' ) then SCA := SCA or 4
- else
- break;
- end;
- MsgDn := WM_KEYDOWN;
- MsgUp := WM_KEYUP;
- if LongBool( SCA and 4 ) then
- begin
- MsgDn := WM_SYSKEYDOWN;
- MsgUp := WM_SYSKEYUP;
- keybd_event( VK_MENU, 0, 0, 0 );
- Send( WM_SYSKEYDOWN, VK_MENU );
- end;
- if LongBool( SCA and 2 ) then
- begin
- keybd_event( VK_CONTROL, 0, 0, 0 );
- Send( WM_KEYDOWN, VK_CONTROL );
- end;
- if Longbool( SCA and 1 ) then
- begin
- keybd_event( VK_SHIFT, 0, 0, 0 );
- Send( WM_KEYDOWN, VK_SHIFT );
- end;
- while not (P^ in [ #0, EndChar ]) do
- begin
- if (P^ = 'F') and (P[ 1 ] in [ '1'..'9' ]) then
- begin
- Inc( P );
- FN := Ord( P^ ) - Ord( '0' );
- if (FN = 1) and (P[ 1 ] in [ '0'..'2' ]) then
- begin
- Inc( P );
- FN := 10 + Ord( P^ ) - Ord( '0' );
- end;
- repeat Inc( P ) until P^ <> ' ';
- FN := FN + $6F;
- Send( MsgDn, FN );
- Send( MsgUp, FN );
- end
- else
- if Compare( 'Numpad' ) then
- begin
- if P^ in [ '0'..'9' ] then
- begin
- FN := Ord( P^ ) - Ord( '0' ) + $60;
- repeat Inc( P^ ) until P^ <> ' ';
- Send( MsgDn, FN );
- Send( MsgUp, FN );
- end;
- end
- else
- if not (CompareSend( 'Add', $6B ) or
- CompareSend( 'Gray+', $6B ) or
- CompareSend( 'Apps', $5D ) or
- CompareSend( 'BackSpace', $08 ) or
- CompareSend( 'BkSp', $08 ) or
- CompareSend( 'BS', $08 ) or
- CompareSend( 'Break', $13 ) or
- CompareSend( 'CapsLock', $14 ) or
- CompareSend( 'Clear', $0C ) or
- CompareSend( 'Decimal', $6E ) or
- CompareSend( 'Del', $2E ) or
- CompareSend( 'Delete', $2E ) or
- CompareSend( 'Divide', $6F ) or
- CompareSend( 'Gray/', $6F ) or
- CompareSend( 'Down', $28 ) or
- CompareSend( 'End', $23 ) or
- CompareSend( 'Enter', $0D ) or
- CompareSend( 'Return', $0D ) or
- CompareSend( 'CR', $0D ) or
- CompareSend( 'Esc', $1B ) or
- CompareSend( 'Escape', $1B ) or
- CompareSend( 'Help', $2F ) or
- CompareSend( 'Home', $24 ) or
- CompareSend( 'Ins', $2D ) or
- CompareSend( 'Insert', $2D ) or
- CompareSend( 'Left', $25 ) or
- CompareSend( 'LWin', $5B ) or
- CompareSend( 'Multiply', $6A ) or
- CompareSend( 'Gray*', $6A ) or
- CompareSend( 'NumLock', $90 ) or
- CompareSend( 'PgDn', $22 ) or
- CompareSend( 'PgUp', $21 ) or
- CompareSend( 'PrintScrn', $2C ) or
- CompareSend( 'Right', $27 ) or
- CompareSend( 'RWin', $5C ) or
- CompareSend( 'Separator', $6C ) or
- CompareSend( 'ScrollLock', $91 ) or
- CompareSend( 'Subtract', $6D ) or
- CompareSend( 'Tab', $09 ) or
- CompareSend( 'Gray-', $6D ) or
- CompareSend( 'Up', $26 )) then break;
- end;
- while not (P^ in [ #0, EndChar ]) do
- begin
- if P^ in [ 'A'..'Z', '0'..'9' ] then
- begin
- Send( MsgDn, Integer( P^ ) );
- Send( MsgUp, Integer( P^ ) );
- end
- else
- if P^ in [ #1..#255 ] then
- Stroke2Window( Wnd, '' + P^ );
- repeat Inc( P ) until (P^ <> ' ');
- end;
- if P^ = EndChar then
- Inc( P );
- if Longbool( SCA and 1 ) then
- begin
- Send( WM_KEYUP, VK_SHIFT );
- keybd_event( VK_SHIFT, 0, KEYEVENTF_KEYUP, 0 );
- end;
- if LongBool( SCA and 2 ) then
- begin
- Send( WM_KEYUP, VK_CONTROL );
- keybd_event( VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 );
- end;
- if LongBool( SCA and 4 ) then
- begin
- Send( WM_SYSKEYUP, VK_MENU );
- keybd_event( VK_MENU, 0, KEYEVENTF_KEYUP, 0 );
- end;
- Result := P;
- end;
-
- begin
- Result := False;
- Wnd := GetTopWindow( Wnd );
- Wnd := GetFocusedChild( Wnd );
- if Wnd = 0 then Exit;
- P := PChar( S );
- while P^ <> #0 do
- begin
- if not (P^ in [ '[', '{' ]) then
- begin
- Stroke2Window( Wnd, '' + P^ );
- Inc( P );
- end
- else
- begin
- if P^ = '[' then
- EndChar := ']'
- else
- EndChar := '}';
- Inc( P );
- P := ParseKeys( EndChar );
- end;
- end;
- Result := True;
- end;
- {$endif win32}
-
- type
- PHWnd = ^HWnd;
-
- TFindWndRec = {$ifndef wince}packed{$endif} Record
- ThreadID : DWord;
- WndFound : HWnd;
- end;
- PFindWndRec = ^TFindWndRec;
-
- //[function EnumWindowsProc]
- function EnumWindowsProc( Wnd : HWnd; Find : PFindWndRec ) : Boolean;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- var Id : DWord;
- begin
- Result := True;
- Id := GetWindowThreadProcessId( Wnd, @Id );
- if Id = Find.ThreadID then
- begin
- Find.WndFound := Wnd;
- Result := False;
- end;
- end;
-
- //[function FindWindowByThreadID]
- function FindWindowByThreadID( ThreadID : DWORD ) : HWnd;
- var Find : TFindWndRec;
- begin
- Find.ThreadID := ThreadID;
- Find.WndFound := 0;
- EnumWindows( @EnumWindowsProc, Integer( @Find ) );
- Result := Find.WndFound;
- end;
-
- //[function DesktopPixelFormat]
- function DesktopPixelFormat: TPixelFormat;
- var DC: HDC;
- Nbits_per_pixel, Nplanes: Integer;
- begin
- DC := GetDC( 0 );
- Nbits_per_pixel := GetDeviceCaps( DC, BITSPIXEL );
- Nplanes := GetDeviceCaps( DC, PLANES );
- ReleaseDC( 0, DC );
- CASE Nplanes * Nbits_per_pixel OF
- 1: Result := pf1bit;
- 4: Result := pf4bit;
- 8: Result := pf8bit;
- 16: Result := pf16bit;
- 24, 32: Result := pf32bit;
- else Result := pfDevice;
- END;
- end;
-
- //[function GetDesktopRect]
- function GetDesktopRect : TRect;
- {$ifdef win32}
- var W1, W2 : HWnd;
- {$endif win32}
- begin
- Result := MakeRect( 0, 0, GetSystemMetrics( SM_CXSCREEN ), GetSystemMetrics( SM_CYSCREEN ) );
- {$ifdef win32}
- W2 := findwindow(nil,'Program Manager');
- W1 := findwindowex(W2,0,'SHELLDLL_DefView',nil);
- if W1 = 0 then Exit;
- GetWindowRect( W1, Result );
- {$endif win32}
- end;
-
- //[function GetWorkArea]
- function GetWorkArea: TRect;
- begin
- SystemParametersInfo( SPI_GETWORKAREA, 0, @ Result, 0 );
- end;
-
- //[function ExecuteWait]
- function ExecuteWait( const AppPath, CmdLine, DfltDirectory: KOLString;
- Show: DWORD; TimeOut: DWORD; ProcID: PDWORD ): Boolean;
- var Flags: DWORD;
- Startup: TStartupInfo;
- ProcInf: TProcessInformation;
- DfltDir, pAppPath: PKOLChar;
- Cmd: KOLString;
- begin
- Result := FALSE;
- {$ifdef wince}
- Flags := 0;
- {$else}
- Flags := CREATE_NEW_CONSOLE;
- if Show = SW_HIDE then
- Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
- {$endif wince}
- FillChar( Startup, SizeOf( Startup ), #0 );
- Startup.cb := Sizeof( Startup );
- Startup.wShowWindow := Show;
- Startup.dwFlags := STARTF_USESHOWWINDOW;
- if ProcID <> nil then
- ProcID^ := 0;
- DfltDir := nil;
- if DfltDirectory <> '' then
- DfltDir := PKOLChar( DfltDirectory );
- if AppPath <> '' then
- pAppPath:=PKOLChar(AppPath)
- else
- pAppPath:=nil;
- Cmd:=CmdLine; // CmdLine parameter must not be const
- if CreateProcess( pAppPath, PKOLChar(Cmd), nil,
- nil, FALSE, Flags, nil, DfltDir, Startup,
- ProcInf ) then
- begin
- if WaitForSingleObject( ProcInf.hProcess, TimeOut ) = WAIT_OBJECT_0 then
- begin
- CloseHandle( ProcInf.hProcess );
- Result := TRUE;
- end
- else
- begin
- if ProcID <> nil then
- ProcID^ := ProcInf.hProcess;
- end;
- CloseHandle( ProcInf.hThread );
- end;
- end;
-
- {$ifdef win32}
- //[function ExecuteIORedirect]
- function ExecuteIORedirect( const AppPath, CmdLine, DfltDirectory: KOLString;
- Show: DWORD; ProcID: PDWORD; InPipe, OutPipeWr, OutPipeRd: PHandle ): Boolean;
- var Flags: DWORD;
- Startup: TStartupInfo;
- ProcInf: TProcessInformation;
- DfltDir: PKOLChar;
- SecurityAttributes: TSecurityAttributes;
- SaveStdOut, SaveStdIn: THandle;
- ChildStdOutRd, ChildStdOutWr: THandle;
- ChildStdInRd, ChildStdInWr: THandle;
- ChildStdOutRdDup: THandle;
- ChildStdInWrDup: THandle;
-
- procedure Do_CloseHandle( var Handle: THandle );
- begin
- if Handle <> 0 then
- begin
- CloseHandle( Handle );
- Handle := 0;
- end;
- end;
-
- procedure Close_Handles;
- begin
- Do_CloseHandle( ChildStdOutRd );
- Do_CloseHandle( ChildStdOutWr );
- Do_CloseHandle( ChildStdInRd );
- Do_CloseHandle( ChildStdInWr );
- end;
-
- function RedirectInputOutput: Boolean;
- begin
- Result := FALSE;
- if (OutPipeRd <> nil) or (OutPipeWr <> nil) then
- begin
- // redirect output
- SaveStdOut := GetStdHandle(STD_OUTPUT_HANDLE);
- if not CreatePipe( ChildStdOutRd, ChildStdOutWr, @ SecurityAttributes, 0 ) then
- Exit;
- if not SetStdHandle( STD_OUTPUT_HANDLE, ChildStdOutWr ) then
- Exit;
- if not DuplicateHandle( GetCurrentProcess, ChildStdOutRd,
- GetCurrentProcess, @ ChildStdOutRdDup, 0, FALSE,
- 2 {DUPLICATE_SAME_ACCESS} ) then
- Exit;
- Do_CloseHandle( ChildStdOutRd );
- if OutPipeRd <> nil then
- OutPipeRd^ := ChildStdOutRdDup;
- if OutPipeWr <> nil then
- OutPipeWr^ := ChildStdOutWr;
- end;
- if InPipe <> nil then
- begin
- // redirect input
- SaveStdIn := GetStdHandle(STD_INPUT_HANDLE);
- if not CreatePipe( ChildStdInRd, ChildStdInWr, @ SecurityAttributes, 0 ) then
- Exit;
- if not SetStdHandle( STD_INPUT_HANDLE, ChildStdInRd ) then
- Exit;
- if not DuplicateHandle( GetCurrentProcess, ChildStdInWr,
- GetCurrentProcess, @ ChildStdInWrDup, 0, FALSE,
- 2 {DUPLICATE_SAME_ACCESS} ) then
- Exit;
- Do_CloseHandle( ChildStdInWr );
- if InPipe <> nil then
- InPipe^ := ChildStdInWrDup;
- Do_CloseHandle( ChildStdInRd );
- end;
- Result := TRUE;
- end;
-
- procedure Restore_Saved_StdInOut;
- begin
- SetStdHandle( STD_OUTPUT_HANDLE, SaveStdOut );
- SetStdHandle( STD_INPUT_HANDLE, SaveStdIn );
- end;
-
- begin
- Result := FALSE;
- Flags := 0;
- if Show = SW_HIDE then
- Flags := Flags or {$IFDEF F_P}$08000000{$ELSE}CREATE_NO_WINDOW{$ENDIF};
- FillChar( Startup, SizeOf( Startup ), #0 );
- Startup.cb := Sizeof( Startup );
- if ProcID <> nil then
- ProcID^ := 0;
- DfltDir := nil;
- SecurityAttributes.nLength := Sizeof( SecurityAttributes );
- SecurityAttributes.lpSecurityDescriptor := nil;
- SecurityAttributes.bInheritHandle := TRUE;
- SaveStdOut := 0;
- SaveStdIn := 0;
- ChildStdOutRd := 0;
- ChildStdOutWr := 0;
- ChildStdInRd := 0;
- ChildStdInWr := 0;
- if not RedirectInputOutput then
- begin
- Close_Handles;
- Exit;
- end;;
- if DfltDirectory <> '' then
- DfltDir := PKOLChar( DfltDirectory );
- if CreateProcess( nil, PKOLChar( '"' + AppPath + '" ' + CmdLine ),
- nil, nil, TRUE, Flags, nil, DfltDir, Startup,
- ProcInf ) then
- begin
- if ProcID <> nil then
- ProcID^ := ProcInf.hProcess
- else
- CloseHandle( ProcInf.hProcess );
- CloseHandle( ProcInf.hThread );
- Restore_Saved_StdInOut;
- Result := TRUE;
- end
- else
- begin
- Restore_Saved_StdInOut;
- Close_Handles;
- Exit;
- end;
- end;
-
- //[function ExecuteConsoleAppIORedirect]
- function ExecuteConsoleAppIORedirect( const AppPath, CmdLine, DfltDirectory: String;
- Show: DWORD; const InStr: String; var OutStr: String; WaitTimeout: DWORD ): Boolean;
- var PipeIn, PipeOutRd, PipeOutWr: THandle;
- ProcID: DWORD;
- BytesCount: DWORD;
- Buffer: array[ 0..4096 ] of Char;
- BufStr: String;
- PPipeIn: PHandle;
- begin
- Result := FALSE;
- PPipeIn := @ PipeIn;
- if InStr = '' then
- PPipeIn := nil;
- PipeOutRd := 0;
- PipeOutWr := 0;
- if not ExecuteIORedirect( AppPath, CmdLine, DfltDirectory, Show, @ ProcID,
- PPipeIn, @ PipeOutWr, @ PipeOutRd ) then Exit;
- if PPipeIn <> nil then
- begin
- if InStr <> '' then
- WriteFile( PipeIn, InStr[ 1 ], Length( InStr ), BytesCount, nil );
- CloseHandle( PipeIn );
- end;
- OutStr := '';
- if WaitForSingleObject( ProcID, WaitTimeOut ) = WAIT_OBJECT_0 then
- begin
- CloseHandle( ProcID );
- CloseHandle( PipeOutWr );
- while ReadFile( PipeOutRd, Buffer, Sizeof( Buffer ), BytesCount, nil ) do
- begin
- SetLength( BufStr, BytesCount );
- Move( Buffer[ 0 ], BufStr[ 1 ], BytesCount );
- OutStr := OutStr + BufStr;
- end;
- end
- else
- CloseHandle( PipeOutWr );
- CloseHandle( PipeOutRd );
- Result := TRUE;
- end;
-
- {$IFDEF _D2}
- //[API OpenProcessToken]
- function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD;
- var TokenHandle: THandle): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- external advapi32 name 'OpenProcessToken';
- {$ENDIF}
-
- //[function WindowsShutdown]
- function WindowsShutdown( const Machine : KOLString; Force, Reboot : Boolean ) : Boolean;
- var
- hToken: THandle;
- tkp, tkp_prev: TTokenPrivileges;
- dwRetLen :DWORD;
- Flags: Integer;
- begin
- Result := False;
- if Integer( GetVersion ) < 0 then // Windows95/98/Me
- begin
- if Machine <> '' then Exit;
- Flags := EWX_SHUTDOWN;
- if Reboot then
- Flags := Flags or EWX_REBOOT;
- if Force then
- Flags := Flags or EWX_FORCE;
- Result := ExitWindowsEx( Flags, 0 );
- Exit;
- end;
-
- OpenProcessToken(GetCurrentProcess(),
- TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
- hToken);
-
- if not LookupPrivilegeValue(PKOLChar(Machine), 'SeShutdownPrivilege',
- tkp.Privileges[0].Luid) then Exit;
- tkp_prev:=tkp;
- tkp.PrivilegeCount:=1;
- tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
- AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,
- dwRetLen);
-
- if not LookupPrivilegeValue(PKOLChar(Machine),
- 'SeRemoteShutdownPrivilege',
- tkp.Privileges[0].Luid)
- then
- Exit;
-
- tkp.PrivilegeCount:=1;
- tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
- AdjustTokenPrivileges(hToken, FALSE, tkp, sizeof(tkp), tkp_prev,
- dwRetLen);
-
- Result := InitiateSystemShutdown(PKOLChar(Machine),nil, 0, Force, Reboot);
- end;
-
- var SaveWinVer: Byte = $FF;
-
- //[function WinVer]
- {$IFDEF ASM_VERSION}
- {$ELSE ASM_VERSION}
- function WinVer : TWindowsVersion;
- var MajorVersion, MinorVersion: Byte;
- dwVersion: Integer;
- begin
- if SaveWinVer <> $FF then Result := TWindowsVersion( SaveWinVer )
- else
- begin
- dwVersion := GetVersion;
- MajorVersion := LoByte( dwVersion );
- MinorVersion := HiByte( LoWord( dwVersion ) );
- if dwVersion >= 0 then
- begin
- Result := wvNT;
- if MajorVersion >= 6 then
- Result := wvVista
- else begin
- if MajorVersion >= 5 then
- if MinorVersion >= 1 then
- begin
- Result := wvXP;
- if MinorVersion >= 2 then
- Result := wvServer2003;
- end
- else Result := wvY2K;
- end;
- end
- else
- begin
- Result := wv95;
- if (MajorVersion > 4) or
- (MajorVersion = 4) and (MinorVersion >= 10) then
- begin
- Result := wv98;
- if (MajorVersion = 4) and (MinorVersion >= $5A) then
- Result := wvME;
- end
- else
- if MajorVersion <= 3 then
- Result := wv31;
- end;
- SaveWinVer := Ord( Result );
- end;
- end;
- {$ENDIF ASM_VERSION}
- {$else}
- function WinVer : TWindowsVersion;
- begin
- Result:=wvCE;
- end;
- {$endif win32}
-
- //[function IsWinVer]
- function IsWinVer( Ver : TWindowsVersions ) : Boolean;
- {* Returns True if Windows version is in given range of values. }
- begin
- Result := WinVer in Ver;
- end;
-
- //[procedure TControl.SetAlphaBlend]
- procedure TControl.SetAlphaBlend(const Value: Integer);
- const
- LWA_COLORKEY=$00000001;
- LWA_ALPHA=$00000002;
- ULW_COLORKEY=$00000001;
- ULW_ALPHA=$00000002;
- ULW_OPAQUE=$00000004;
- WS_EX_LAYERED=$00080000;
- type
- TSetLayeredWindowAttributes=
- function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD )
- : Boolean; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var
- SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
- User32: THandle;
- dw: DWORD;
- begin
- if Value = fAlphaBlend then Exit;
- fAlphaBlend := Value;
- User32 := GetModuleHandle( 'User32' );
- SetLayeredWindowAttributes := GetProcAddress( User32,
- 'SetLayeredWindowAttributes' );
- if Assigned( SetLayeredWindowAttributes ) then
- begin
- dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE );
- if Byte( Value ) < 255 then
- begin
- SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED );
- SetLayeredWindowAttributes( fHandle, 0, Value and $FF, LWA_ALPHA);
- end
- else
- SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED );
- end;
- end;
-
- {$ENDIF WIN_GDI}
- //[function TControl.SetPosition]
- function TControl.SetPosition( X, Y: Integer ): PControl;
- begin
- Left := X;
- Top := Y;
- Result := @Self;
- end;
- {$IFDEF WIN_GDI}
-
- //[function NewColorDialog]
- function NewColorDialog( FullOpen: TColorCustomOption ): PColorDialog;
- var I: Integer;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PColorDialog.Create;*){--}
- Result.ColorCustomOption := FullOpen;
- for I := 1 to 16 do
- Result.CustomColors[ I ] := clWhite;
- end;
- //[END NewColorDialog]
-
- { TColorDialog }
-
- //[function TColorDialog.Execute]
- function TColorDialog.Execute: Boolean;
- var CD: TChooseColor;
- begin
- CD.lStructSize := Sizeof( CD );
- CD.hWndOwner := OwnerWindow;
- //CD.hInstance := 0;
- CD.rgbResult := Color2RGB( Color );
- CD.lpCustColors := @CustomColors[ 1 ];
- CD.Flags := CC_RGBINIT;
- case ColorCustomOption of
- ccoFullOpen: CD.Flags := CD.Flags or CC_FULLOPEN;
- ccoPreventFullOpen: CD.Flags := CD.Flags or CC_PREVENTFULLOPEN;
- end;
- Result := ChooseColor( {$ifdef wince}@{$endif}CD );
- if Result then
- Color := CD.rgbResult;
- end;
-
- //[procedure TControl.SetMaxProgress]
- procedure TControl.SetMaxProgress(const Index, Value: Integer);
- begin
- // ignore index, and set Value via PBM_SETRANGE32: ()
- Perform( PBM_SETRANGE32, 0, Value );
- end;
-
- //[procedure TControl.SetDroppedWidth]
- procedure TControl.SetDroppedWidth(const Value: Integer);
- begin
- FDroppedWidth := Value;
- Perform( CB_SETDROPPEDWIDTH, Value, 0 );
- end;
-
- //[function TControl.LVGetItemState]
- function TControl.LVGetItemState(Idx: Integer): TListViewItemState;
- type
- PListViewItemState = ^TListViewItemState;
- var I: integer;
- begin
- I := Perform( LVM_GETITEMSTATE, Idx,
- LVIS_CUT or LVIS_DROPHILITED or LVIS_FOCUSED or LVIS_SELECTED );
- Result := PListViewItemState( @ I )^;
- end;
-
- //[procedure TControl.LVSetItemState]
- procedure TControl.LVSetItemState(Idx: Integer; const Value: TListViewItemState);
- var Data: TLVItem;
- begin
- Data.stateMask := LVIS_FOCUSED or LVIS_SELECTED or LVIS_CUT or LVIS_DROPHILITED;
- Data.state := PByte( @ Value )^;
- Perform( LVM_SETITEMSTATE, Idx, Integer( @Data ) );
- end;
-
- //[procedure TControl.LVSelectAll]
- procedure TControl.LVSelectAll;
- begin
- LVSetItemState( -1, [ lvisSelect ] );
- end;
-
- //[function TControl.LVItemInsert]
- function TControl.LVItemInsert(Idx: Integer; const aText: KOLString): Integer;
- var LVI: TLVItem;
- begin
- LVI.mask := LVIF_TEXT;
- LVI.iItem := Idx;
- LVI.iSubItem := 0;
- LVI.pszText := PKOL_Char( aText );
- Result := Perform( LVM_INSERTITEM, 0, Integer( @LVI ) );
- end;
-
- //[function TControl.LVItemAdd]
- function TControl.LVItemAdd(const aText: KOLString): Integer;
- begin
- Result := LVItemInsert( Count, aText );
- end;
-
- //[function TControl.LVGetSttImgIdx]
- function TControl.LVGetSttImgIdx(Idx: Integer): Integer;
- begin
- Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_STATEIMAGEMASK ) shr 12;
- end;
-
- //[procedure TControl.LVSetSttImgIdx]
- procedure TControl.LVSetSttImgIdx(Idx: Integer; const Value: Integer);
- var LVI: TLVItem;
- begin
- LVI.stateMask := LVIS_STATEIMAGEMASK;
- LVI.state := Value shl 12;
- Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
- end;
-
- //[function TControl.LVGetOvlImgIdx]
- function TControl.LVGetOvlImgIdx(Idx: Integer): Integer;
- begin
- Result := Perform( LVM_GETITEMSTATE, Idx, LVIS_OVERLAYMASK ) shr 8;
- end;
-
- //[procedure TControl.LVSetOvlImgIdx]
- procedure TControl.LVSetOvlImgIdx(Idx: Integer; const Value: Integer);
- var LVI: TLVItem;
- begin
- LVI.stateMask := LVIS_OVERLAYMASK;
- LVI.state := Value shl 8;
- Perform( LVM_SETITEMSTATE, Idx, Integer( @LVI ) );
- end;
-
- //[function TControl.LVGetItemData]
- function TControl.LVGetItemData(Idx: Integer): DWORD;
- var LVI: TLVItem;
- begin
- LVI.mask := LVIF_PARAM;
- LVI.iItem := Idx;
- LVI.iSubItem := 0;
- Perform( LVM_GETITEM, 0, Integer( @LVI ) );
- Result := LVI.lParam;
- end;
-
- //[procedure TControl.LVSetItemData]
- procedure TControl.LVSetItemData(Idx: Integer; const Value: DWORD);
- var LVI: TLVItem;
- begin
- LVI.mask := LVIF_PARAM;
- LVI.iItem := Idx;
- LVI.iSubItem := 0;
- LVI.lParam := Value;
- Perform( LVM_SETITEM, 0, Integer( @LVI ) );
- end;
-
- //[function TControl.LVGetItemIndent]
- function TControl.LVGetItemIndent(Idx: Integer): Integer;
- var LI: TLVItem;
- begin
- LI.mask := LVIF_INDENT;
- LI.iItem := Idx;
- LI.iSubItem := 0;
- Perform( LVM_GETITEM, 0, Integer( @LI ) );
- Result := LI.iIndent;
- end;
-
- //[procedure TControl.LVSetItemIndent]
- procedure TControl.LVSetItemIndent(Idx: Integer; const Value: Integer);
- var LI: TLVItem;
- begin
- LI.mask := LVIF_INDENT;
- LI.iItem := Idx;
- LI.iSubItem := 0;
- LI.iIndent := Value;
- Perform( LVM_SETITEM, 0, Integer( @LI ) );
- end;
-
- type
- TNMLISTVIEW = {$ifndef wince}packed{$endif} Record
- hdr: TNMHDR;
- iItem: Integer;
- iSubItem: Integer;
- uNewState: Integer;
- uOldState: Integer;
- uChanged: Integer;
- ptAction: Integer;
- lParam: DWORD;
- end;
- PNMLISTVIEW = ^TNMLISTVIEW;
-
- //[function WndProc_LVDeleteItem]
- function WndProc_LVDeleteItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var Hdr: PNMHDR;
- LV: PNMListView;
- begin
- Result := FALSE;
- if Msg.message = WM_NOTIFY then
- begin
- Hdr := Pointer(Msg.lParam);
- if Hdr.hwndFrom = Sender.Handle then
- begin
- LV := Pointer( Hdr );
- if LongInt(Hdr.code) = LVN_DELETEITEM then
- begin
- if Assigned( Sender.OnDeleteLVItem ) then
- Sender.OnDeleteLVItem( Sender, LV.iItem );
- Result := TRUE;
- end
- else
- if LongInt(Hdr.code) = LVN_DELETEALLITEMS then
- begin
- if Assigned( Sender.OnDeleteAllLVItems ) then
- begin
- Sender.OnDeleteAllLVItems( Sender );
- Rslt := 0;
- if Assigned( Sender.OnDeleteLVItem ) then
- Rslt := 1;
- end;
- Result := TRUE;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnDeleteAllLVItems]
- procedure TControl.SetOnDeleteAllLVItems(const Value: TOnEvent);
- begin
- fOnDeleteAllLVItems := Value;
- AttachProc( @WndProc_LVDeleteItem );
- end;
-
- //[procedure TControl.SetOnDeleteLVItem]
- procedure TControl.SetOnDeleteLVItem(const Value: TOnDeleteLVItem);
- begin
- fOnDeleteLVItem := Value;
- AttachProc( @WndProc_LVDeleteItem );
- end;
-
- //[function WndProc_LVData]
- function WndProc_LVData( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var Hdr: PNMHDR;
- DI: PLVDispInfo;
- Store: Boolean;
- Txt: KOL_String;
- LV: PControl;
- begin
- Result := FALSE;
- if Msg.message = WM_NOTIFY then
- begin
- Hdr := Pointer(Msg.lParam);
- if Hdr.hwndFrom = Sender.Handle then
- begin
- if (LongInt(Hdr.code) = LVN_GETDISPINFO)
- {$IFDEF UNICODE_CTRLS}
- or (LongInt(Hdr.code) = LVN_GETDISPINFOW)
- {$ENDIF UNICODE_CTRLS}
- then
- begin
- DI := Pointer( Hdr );
- LV := Sender;
- if LV <> nil then
- begin
- DI.item.iImage := -1;
- DI.item.state := 0;
- Store := FALSE;
- if Assigned( LV.OnLVData ) and (DI.item.iItem >= 0) then
- begin
- LV.OnLVData( LV, DI.item.iItem, DI.item.iSubItem, Txt,
- DI.item.iImage, DWORD( DI.item.state ), Store );
- if LongBool(DI.item.mask and LVIF_TEXT) then begin
- LV.fCaption := Txt;
- DI.item.pszText := PKOL_Char( PKOLChar( LV.fCaption ) );
- end;
- DI.item.stateMask := 0;
- if DI.item.state and LVIS_STATEIMAGEMASK <> 0 then
- DI.item.stateMask := LVIS_STATEIMAGEMASK;
- if DI.item.state and LVIS_OVERLAYMASK <> 0 then
- DI.item.stateMask := DI.item.stateMask or LVIS_OVERLAYMASK;
- if DI.item.state and $7F <> 0 then
- DI.item.stateMask := DI.item.stateMask or $7F;
- if Store then
- DI.item.mask := DI.item.mask or LVIF_DI_SETITEM;
- end;
- Result := TRUE;
- end;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnLVData]
- procedure TControl.SetOnLVData(const Value: TOnLVData);
- begin
- fOnLVData := Value;
- AttachProc( @WndProc_LVData );
- Perform( LVM_SETCALLBACKMASK, LVIS_OVERLAYMASK or LVIS_STATEIMAGEMASK, 0 );
- end;
-
- {$IFDEF ENABLE_DEPRECATED}
- {$DEFINE implementation} {$I KOL_deprecated.inc} {$UNDEF implementation}
- {$ENDIF DISABLE_DEPRECATED}
-
- //[function WndProc_LVCustomDraw]
- function WndProc_LVCustomDraw( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
- var NMCustDraw: PNMLVCustomDraw;
- NMHdr: PNMHdr;
- ItemIdx, SubItemIdx: Integer;
- S: TListViewItemState;
- ItemState: TDrawState;
- begin
- Result := FALSE;
- if Msg.message = WM_NOTIFY then
- begin
- NMHdr := Pointer( Msg.lParam );
- if (LongInt(NMHdr.code) = NM_CUSTOMDRAW) and Assigned( Sender.fOnLVCustomDraw ) then
- begin
- NMCustDraw := Pointer( Msg.lParam );
- ItemIdx := -1;
- SubItemIdx := -1;
- if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_ITEM ) then
- ItemIdx := NMCustDraw.nmcd.dwItemSpec;
- if LongBool( NMCustDraw.nmcd.dwDrawStage and CDDS_SUBITEM ) then
- SubItemIdx := NMCustDraw.iSubItem;
- ItemState := [ ];
- if ItemIdx >= 0 then
- begin
- S := Sender.LVItemState[ ItemIdx ];
- if lvisFocus in S then
- ItemState := ItemState + [ odsFocused ];
- if lvisSelect in S then
- ItemState := ItemState + [ odsSelected ];
- if lvisBlend in S then
- ItemState := ItemState + [ odsGrayed ];
- if lvisHighlight in S then
- ItemState := ItemState + [ odsMarked ];
- end;
-
- Sender.Canvas;
-
- Rslt := Sender.FOnLVCustomDraw( Sender, {Sender.fPaintDC} NMCustDraw.nmcd.hdc,
- NMCustDraw.nmcd.dwDrawStage, ItemIdx, SubItemIdx, NMCustDraw.nmcd.rc,
- ItemState, TColor( NMCustDraw.clrText ), TColor( NMCustDraw.clrTextBk ) );
-
- Result := TRUE;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnLVCustomDraw]
- procedure TControl.SetOnLVCustomDraw(const Value: TOnLVCustomDraw);
- begin
- fOnLVCustomDraw := Value;
- AttachProc( @WndProc_LVCustomDraw );
- end;
-
- //[function CompareLVItems]
- function CompareLVItems( Idx1, Idx2: Integer; ListView: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- if Assigned( ListView.fOnCompareLVItems ) then
- Result := ListView.fOnCompareLVItems( ListView, Idx1, Idx2 )
- else
- Result := 0;
- end;
-
- //[procedure TControl.LVSort]
- procedure TControl.LVSort;
- begin
- {$ifdef wince}
- MsgOk('TControl.LVSort must be fixed!');
- Halt(6); // FIXME
- {$else}
- Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVItems) );
- {$endif wince}
- end;
-
- //[function CompareLVItemsData]
- function CompareLVItemsData( D1, D2: DWORD; ListView: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- begin
- if Assigned( ListView.fOnCompareLVItems ) then
- Result := ListView.fOnCompareLVItems( ListView, D1, D2 )
- else
- Result := 0;
- end;
-
- //[procedure TControl.LVSortData]
- procedure TControl.LVSortData;
- begin
- Perform( LVM_SORTITEMS, Integer( @Self ), Integer( @CompareLVItemsData ) );
- end;
-
- //[function WndProc_LVColumnClick]
- function WndProc_LVColumnClick( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var Hdr: PNMHDR;
- LV: PNMListView;
- begin
- Result := FALSE;
- if Msg.message = WM_NOTIFY then
- begin
- Hdr := Pointer(Msg.lParam);
- if Hdr.hwndFrom = Sender.Handle then
- begin
- LV := Pointer( Hdr );
- if LongInt(Hdr.code) = LVN_COLUMNCLICK then
- begin
- if Assigned( Sender.OnColumnClick ) then
- Sender.OnColumnClick( Sender, LV.iSubItem );
- Result := TRUE;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnColumnClick]
- procedure TControl.SetOnColumnClick(const Value: TOnLVColumnClick);
- begin
- fOnColumnClick := Value;
- AttachProc( @WndProc_LVColumnClick );
- end;
-
- //[function WndProc_LVStateChange]
- function WndProc_LVStateChange( Sender: PControl; var Msg: TMsg; var R: Integer ): Boolean;
- var NMOD: PNMLVODStateChange;
- NMLV: PNMLISTVIEW;
- begin
- if Msg.message = WM_NOTIFY then
- begin
- NMOD := Pointer( Msg.lParam );
- NMLV := Pointer( Msg.lParam );
- if LongInt(NMOD.hdr.code) = LVN_ODSTATECHANGED then
- begin
- if Assigned( Sender.OnLVStateChange ) then
- Sender.OnLVStateChange( Sender, NMOD.iFrom, NMOD.iTo,
- NMOD.uOldState, NMOD.uNewState );
- end
- else
- if LongInt(NMLV.hdr.code) = LVN_ITEMCHANGED then
- begin
- if Assigned( Sender.OnLVStateChange ) then
- Sender.OnLVStateChange( Sender, NMLV.iItem, NMLV.iItem,
- NMLV.uOldState, NMLV.uNewState );
- end;
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.SetOnLVStateChange]
- procedure TControl.SetOnLVStateChange(const Value: TOnLVStateChange);
- begin
- FOnLVStateChange := Value;
- AttachProc( WndProc_LVStateChange );
- end;
-
- //[function CompareLVColumns]
- function CompareLVColumns( Idx1, Idx2: Integer; Sender: PControl ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var S1, S2: String;
- begin
- //--- changed by Mike Gerasimov:
- S1 := Sender.LVItems[ Idx1, Sender.fColumn ];
- S2 := Sender.LVItems[ Idx2, Sender.fColumn ];
- If lvoSortAscending in Sender.fLVOptions Then
- Result := AnsiCompareStrNoCase( S1, S2 )
- Else
- If lvoSortDescending in Sender.fLVOptions Then
- Result := AnsiCompareStrNoCase( S2, S1 )
- Else
- Result:=0;
- end;
-
- //[procedure TControl.LVSortColumn]
- procedure TControl.LVSortColumn(Idx: Integer);
- begin
- fColumn := Idx;
- {$ifdef wince}
- MsgOk('TControl.LVSortColumn must be fixed!');
- Halt(6); // FIXME
- {$else}
- Perform( LVM_SORTITEMSEX, Integer(@Self), Integer(@CompareLVColumns) );
- {$endif wince}
- end;
-
- //[function TControl.LVIndexOf]
- function TControl.LVIndexOf(const S: KOLString): Integer;
- begin
- Result := LVSearchFor( S, -1, FALSE );
- end;
-
- //[function TControl.LVSearchFor]
- function TControl.LVSearchFor(const S: KOLString; StartAfter: Integer;
- Partial: Boolean): Integer;
- var f: TLVFindInfo;
- begin
- f.lParam := 0;
- f.flags := LVFI_STRING;
- if Partial then
- f.flags := LVFI_STRING or LVFI_PARTIAL;
- f.psz := @s[1];
- result := Perform(LVM_FINDITEM,StartAfter,integer(@f));
- end;
-
- function WndProcLVMeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var
- pMI: PMeasureItemStruct;
- P: PControl;
- H: Integer;
- wId: DWORD;
- i: Integer;
- begin
- Result := FALSE;
- if Msg.message = WM_MEASUREITEM then begin
- pMI := Pointer(Msg.lParam);
- with pMI^ do begin
- for i:=0 to Sender.ChildCount-1 do begin
- P := Sender.Children[i];
- if P <> nil then begin
- wId := GetWindowLong(P.Handle,GWL_ID);
- if CtlID = wId then begin
- H := P.fLVItemHeight;
- if H > 0 then begin
- itemHeight := H;
- Rslt:=1;
- Result := TRUE;
- end;
- break;
- end;
- end;
- end;
- end;
- end;
- end;
-
- function TControl.SetLVItemHeight(Value: Integer): PControl;
- begin
- Set_LVItemHeight( Value );
- Result := @ Self;
- end;
-
- procedure TControl.Set_LVItemHeight(Value: Integer);
- begin
- if fLVItemHeight <> Value then begin
- if fLVItemHeight = 0 then
- Parent.AttachProc(WndProcLVMeasureItem);
- fLVItemHeight := Value;
- end;
- end;
-
- //[function TControl.IndexOf]
- function TControl.IndexOf(const S: KOLString): Integer;
- begin
- Result := SearchFor( S, -1, FALSE );
- end;
-
- //[function TControl.SearchFor]
- function TControl.SearchFor(const S: KOLString; StartAfter: Integer;
- Partial: Boolean): Integer;
- var Cmd: Integer;
- I: Integer;
- begin
- Cmd := fCommandActions.aFindItem;
- if Partial then
- Cmd := fCommandActions.aFindPartial;
- if Cmd <> 0 then
- Result := Perform( Cmd, StartAfter, Integer( PKOLChar( S ) ) )
- else
- begin
- Result := -1;
- for I := StartAfter+1 to Count-1 do
- begin
- if Partial and ( Copy( Items[ I ], 1, Length( S ) ) = S ) or
- ( Items[ I ] = S ) then
- begin
- Result := I;
- break;
- end;
- end;
- end;
- end;
-
- //[function TControl.DefaultBtnProc]
- function TControl.DefaultBtnProc(var Msg: TMsg;
- var Rslt: Integer): Boolean;
- var Btn: PControl;
- F: PControl;
- begin
- if Assigned( fOldOnMessage ) then
- begin
- Result := fOldOnMessage( Msg, Rslt );
- if Result then Exit;
- end;
- Result := FALSE;
- if AppletTerminated then Exit;
- F := Applet;
- if not F.fIsForm then
- begin
- F := F.fCurrentControl;
- if F = nil then Exit;
- end;
- Btn := nil;
- if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
- ((Msg.wParam = VK_RETURN) or (Msg.wParam = VK_ESCAPE)) then
- begin
- if (Msg.wParam = VK_RETURN) and
- (F.fDefaultBtnCtl <> nil) and
- F.fDefaultBtnCtl.ToBeVisible and
- F.fDefaultBtnCtl.Enabled and
- ((F.fCurrentControl=nil) or (not F.fCurrentControl.fCancelBtn and
- not F.fCurrentControl.fIgnoreDefault)
- or (F.fCurrentControl = F.fDefaultBtnCtl)
- ) then
- Btn := F.fDefaultBtnCtl
- else
- if (Msg.wParam = VK_ESCAPE) and
- (F.fCancelBtnCtl <> nil) and
- F.fCancelBtnCtl.ToBeVisible and
- F.fCancelBtnCtl.Enabled then
- Btn := F.fCancelBtnCtl
- else
- if (Msg.wParam = VK_RETURN) and
- (F.fAllBtnReturnClick or fAllBtnReturnClick) and
- (F.ActiveControl <> nil) and
- (F.ActiveControl.ToBeVisible) and
- (F.ActiveControl.IsButton) and
- (F.ActiveControl.Count = 0) then
- Btn := F.ActiveControl;
- if Btn <> nil then
- begin
- if Msg.message = WM_KEYDOWN then
- begin
- {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
- //Btn.Click;
- if Assigned( Btn.OnClick ) then
- Btn.OnClick( Btn );
- {$ELSE}
- Btn.Focused := TRUE;
- {$ENDIF}
- end;
- {$IFDEF CLICK_DEFAULT_CANCEL_BTN_DIRECTLY}
- {$ELSE}
- Btn.Perform( Msg.message, DWORD( ' ' ), Msg.lParam );
- {$ENDIF}
- Msg.wParam := 0;
- Result := TRUE;
- Rslt := 0;
- Exit;
- end
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.SetDefaultBtn]
- procedure TControl.SetDefaultBtn(const Index: Integer;
- const Value: Boolean);
- var F, C: PControl;
- begin
- if Index = 13 then
- begin
- fDefaultBtn := Value;
- {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
- fCancelBtn := FALSE;
- {$ENDIF}
- end
- else
- if Index = 27 then
- begin
- fCancelBtn := Value;
- {$IFDEF DEFAULT_CANCEL_BTN_EXCLUSIVE}
- fDefaultBtn := FALSE;
- {$ENDIF}
- end;
- if Applet = nil then Exit;
- F := ParentForm;
- if F <> nil then
- begin
- if Value then
- begin
- if @ Applet.fOnMessage <> @ TControl.DefaultBtnProc then
- Applet.fOldOnMessage := Applet.fOnMessage; // fixed by YS
- Applet.fOnMessage := Applet.DefaultBtnProc;
- end
- else
- begin
- Applet.fOnMessage := Applet.fOldOnMessage;
- Applet.fOldOnMessage := nil;
- end;
- C := nil;
- if Value then C := @ Self;
- if Index = 13 then
- begin
- F.fDefaultBtnCtl := C;
- {$ifndef wince}
- {$IFDEF NO_DEFAULT_BUTTON_BOLD}
- {$ELSE}
- if Value then
- Style := Style or BS_DEFPUSHBUTTON
- else
- Style := Style and not BS_DEFPUSHBUTTON;
- {$ENDIF}
- {$endif wince}
- end
- else
- if Index = 27 then
- F.fCancelBtnCtl := C;
- end;
- end;
-
- {$IFDEF F_P}
- //[function TControl.GetDefaultBtn]
- function TControl.GetDefaultBtn(const Index: Integer): Boolean;
- begin
- CASE Index OF
- 13: Result := fDefaultBtn;
- 27: Result := fCancelBtn;
- END;
- end;
- {$ENDIF F_P}
-
- //[function TControl.AllBtnReturnClick]
- function TControl.AllBtnReturnClick: PControl;
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- begin
- // nothing: already implemented in WndProcBtnReturnClick
- Result := @ Self;
- end;
- {$ELSE}
- var F: PControl;
- begin
- SetDefaultBtn( 0, TRUE );
- F := ParentForm;
- if F <> nil then
- F.fAllBtnReturnClick := TRUE;
- Result := @ Self;
- end;
- {$ENDIF}
-
- //[function WndProc_CNDrawItem]
- function WndProc_CNDrawItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- type PDrawAction = ^TDrawAction;
- PDrawState = ^TDrawState;
- var DI: PDrawItemStruct;
- begin
- Result := FALSE;
- if Msg.message = CN_DRAWITEM then
- begin
- DI := Pointer( Msg.lParam );
- if Assigned( Sender.OnDrawItem ) then
- begin
- if Sender.OnDrawItem( Sender, DI.hDC, DI.rcItem, DI.itemID,
- PDrawAction( @ DI.itemAction )^,
- PDrawState( @ DI.itemState )^ )
- then Rslt := 1
- else Rslt := 0;
- Result := TRUE;
- end
- else Rslt := 0;
- end;
- end;
-
- //[procedure TControl.SetOnDrawItem]
- procedure TControl.SetOnDrawItem(const Value: TOnDrawItem);
- begin
- fOnDrawItem := Value;
- if Parent <> nil then
- Parent.AttachProc( @WndProc_DrawItem );
- AttachProc( @WndProc_CNDrawItem );
- end;
-
- //[function WndProc_MeasureItem]
- function WndProc_MeasureItem( Sender: PControl; var Msg: TMsg; var Rslt: Integer )
- : Boolean;
- var MI: PMeasureItemStruct;
- Control: PControl;
- I: Integer;
- begin
- Result := FALSE;
- if Msg.message = WM_MEASUREITEM then
- begin
- MI := Pointer( Msg.lParam );
- for I := 0 to Sender.ChildCount - 1 do
- begin
- Control := Sender.Children[ I ];
- if Control.Menu = MI.CtlID then
- begin
- if Assigned( Control.OnMeasureItem ) then
- begin
- MI.itemHeight := Control.OnMeasureItem( Control, MI.itemID );
- if MI.itemHeight > 0 then
- begin
- Rslt := 1;
- Result := TRUE;
- end;
- end;
- break;
- end;
- end;
- end;
- end;
-
- //[procedure TControl.SetOnMeasureItem]
- procedure TControl.SetOnMeasureItem(const Value: TOnMeasureItem);
- begin
- fOnMeasureItem := Value;
- if Parent <> nil then
- Parent.AttachProc( @WndProc_MeasureItem );
- end;
-
- //[function TControl.GetItemData]
- function TControl.GetItemData(Idx: Integer): DWORD;
- begin
- Result := 0;
- if fCommandActions.aGetItemData <> 0 then
- Result := Perform( fCommandActions.aGetItemData, Idx, 0 );
- end;
-
- //[procedure TControl.SetItemData]
- procedure TControl.SetItemData(Idx: Integer; const Value: DWORD);
- begin
- if fCommandActions.aSetItemData <> 0 then
- Perform( fCommandActions.aSetItemData, Idx, Value );
- end;
-
- //[function TControl.GetLVCurItem]
- function TControl.GetLVCurItem: Integer;
- begin
- Result := Perform( LVM_GETNEXTITEM, -1, LVNI_SELECTED );
- end;
-
- //[procedure TControl.SetLVCurItem]
- procedure TControl.SetLVCurItem(const Value: Integer);
- begin
- if (lvoMultiselect in LVOptions) or (Value <> LVCurItem ) then
- LVItemState[ -1 ] := [ ];
- if Value >= 0 then
- LVItemState[ Value ] := [ lvisSelect, lvisFocus ];
- end;
-
- //[function TControl.LVNextItem]
- function TControl.LVNextItem(IdxPrev: Integer; Attrs: DWORD): Integer;
- begin
- Result := Perform( LVM_GETNEXTITEM, IdxPrev, Attrs );
- end;
-
- //[function TControl.LVNextSelected]
- function TControl.LVNextSelected(IdxPrev: Integer): Integer;
- begin
- Result := Perform( LVM_GETNEXTITEM, IdxPrev, LVNI_SELECTED );
- end;
-
- //[function TControl.GetLVFocusItem]
- function TControl.GetLVFocusItem: Integer;
- begin
- Result := Perform( LVM_GETNEXTITEM, -1, LVNI_FOCUSED );
- end;
-
- //[procedure TControl.Close]
- procedure TControl.Close;
- begin
- PostMessage( Handle, WM_CLOSE, 0, 0 );
- end;
-
- //[function WndProcMinimize]
- function WndProcMinimize( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Wnd: PControl;
- begin
- Result := FALSE;
- if (Msg.message = WM_SYSCOMMAND) and ((Msg.wParam and $FFF0) = SC_MINIMIZE)then
- begin
- if Applet <> nil then
- begin
- Wnd := Applet.FMinimizeWnd;
- if Wnd <> nil then
- SetWindowPos( Applet.Handle, 0, Wnd.Left, Wnd.Top, Wnd.Width, 0,
- SWP_NOZORDER or SWP_NOREDRAW);
- end;
- end;
- end;
-
- function WndProcRestore( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- begin
- Result := FALSE;
- CASE Msg.message OF
- WM_SHOWWINDOW:
- begin
- case Msg.lParam of
- SW_PARENTCLOSING:
- begin
- {$ifdef win32}
- if IsIconic( Self_.fHandle ) then
- Self_.fShowAction := SW_SHOWMINNOACTIVE
- else
- if IsZoomed( Self_.fHandle ) then
- Self_.fShowAction := SW_SHOWMAXIMIZED
- else
- Self_.fShowAction := SW_SHOWNOACTIVATE;
- {$endif win32}
- end;
- SW_PARENTOPENING:
- begin
- if Self_.fShowAction <> 0 then
- begin
- ShowWindow( Self_.fHandle, Self_.fShowAction );
- Self_.fShowAction := 0;
- end;
- Rslt := 0;
- end;
- end;
- end;
- END;
- end;
-
- //[procedure TControl.MinimizeNormalAnimated]
- procedure TControl.MinimizeNormalAnimated;
- var App: PControl;
- begin
- App := Applet;
- if App = nil then
- App := @Self;
- App.FMinimizeWnd := @Self;
- App.AttachProc( @WndProcMinimize );
- AttachProc( @WndProcRestore );
- end;
-
- //[procedure TCotrol.RestoreNormalMaximized]
- procedure TControl.RestoreNormalMaximized;
- begin
- AttachProc( @WndProcRestore );
- end;
-
- {$ifndef wince}
- //[function WndProcDropFiles]
- function WndProcDropFiles( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var hDrop: THandle;
- Pt: TPoint;
- FList: KOLString;
- I, N: Integer;
- Buf: array[ 0..MAX_PATH ] of KOLChar;
- begin
- if Msg.message = WM_DROPFILES then
- if Assigned( Sender.FOnDropFiles ) then
- begin
- hDrop := Msg.wParam;
- DragQueryPoint( hDrop, Pt );
- N := DragQueryFile( hDrop, $FFFFffff, nil, 0 );
- FList := '';
- for I := 0 to N-1 do
- begin
- if FList <> '' then
- FList := FList + #13;
- DragQueryFile( hDrop, I, Buf, Sizeof( Buf ) );
- FList := FList + Buf;
- end;
- DragFinish( hDrop );
- Sender.FOnDropFiles( Sender, FList, Pt );
- Rslt := 0;
- Result := TRUE;
- Exit;
- end;
- Result := FALSE;
- end;
- {$endif wince}
- //[procedure TControl.SetOnDropFiles]
- procedure TControl.SetOnDropFiles(const Value: TOnDropFiles);
- begin
- FOnDropFiles := Value;
- {$ifndef wince}
- AttachProc( @WndProcDropFiles );
- DragAcceptFiles( GetWindowHandle, Assigned( Value ) );
- {$endif wince}
- end;
-
- //[function WndProcShowHide]
- function WndProcShowHide( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var IsVisible: Boolean;
- begin
- if Msg.message = WM_SHOWWINDOW then
- if Msg.hwnd = Sender.Handle then
- begin
- IsVisible := IsWindowVisible( Sender.Handle );
- if LongBool( Msg.wParam ) then
- begin
- Sender.fVisible := TRUE;
- if not IsVisible then
- if Assigned( Sender.FOnShow ) then
- Sender.FOnShow( Sender );
- end
- else
- begin
- Sender.fVisible := FALSE;
- if IsVisible then
- if Assigned( Sender.FOnHide ) then
- Sender.FOnHide( Sender );
- end;
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.SetOnHide]
- procedure TControl.SetOnHide(const Value: TOnEvent);
- begin
- FOnHide := Value;
- AttachProc( WndProcShowHide );
- end;
-
- //[procedure TControl.SetOnShow]
- procedure TControl.SetOnShow(const Value: TOnEvent);
- begin
- FOnShow := Value;
- AttachProc( WndProcShowHide );
- end;
-
- //[function TControl.BringToFront]
- function TControl.BringToFront: PControl;
- begin
- SetWindowPos( GetWindowHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
- SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_SHOWWINDOW );
- Result := @Self;
- end;
-
- //[function TControl.SendToBack]
- function TControl.SendToBack: PControl;
- begin
- SetWindowPos( GetWindowHandle, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
- SWP_NOACTIVATE or SWP_NOOWNERZORDER );
- Result := @Self;
- end;
-
- //[procedure TControl.DragStart]
- procedure TControl.DragStart;
- begin
- PostMessage( GetWindowHandle, WM_SYSCOMMAND, $F012, 0 );
- end;
-
- //[function WndProcDragWindow]
- function WndProcDragWindow( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var P: TPoint;
- begin
- if Msg.message = WM_MOUSEMOVE then
- begin
- if Sender.FDragging then
- begin
- GetCursorPos( P );
- P.x := P.x - Sender.fMouseStartPos.x + Sender.fDragStartPos.x;
- P.y := P.y - Sender.fMouseStartPos.y + Sender.fDragStartPos.y;
- Sender.Position := P;
- end;
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.DragStartEx]
- procedure TControl.DragStartEx;
- var StartBounds: TRect;
- begin
- {$IFNDEF SMALLEST_CODE}
- if fDragging then Exit;
- {$ENDIF}
- GetCursorPos( fMouseStartPos );
- StartBounds := BoundsRect;
- fDragStartPos.x := StartBounds.Left;
- fDragStartPos.y := StartBounds.Top;
- SetCapture( GetWindowHandle );
- fDragging := TRUE;
- AttachProc( WndProcDragWindow );
- end;
-
- //[procedure TControl.DragStopEx]
- procedure TControl.DragStopEx;
- begin
- if FDragging then
- begin
- ReleaseCapture;
- FDragging := FALSE;
- end;
- end;
-
- //[function CallDragCallBack]
- function CallDragCallBack( Sender: PControl; var Stop: Boolean ): Boolean;
- var P: TPoint;
- Shape, ShapeWas: Integer;
- begin
- Sender.AttachProc( WndProcSetCursor );
- GetCursorPos( P );
- Shape := LoadCursor( 0, IDC_HAND );
- ShapeWas := Shape;
- Result := Sender.fDragCallback( Sender, P.x, P.y, Shape, Stop );
- if not Stop then
- begin
- if not Result then
- if Shape = ShapeWas then
- Shape := LoadCursor( 0, IDC_NO );
- ScreenCursor := Shape;
- end
- else
- begin
- ScreenCursor := 0;
- Shape := Sender.fCursor;
- end;
- Windows.SetCursor( Shape );
- end;
-
- //[function WndProcDrag]
- function WndProcDrag( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Stop: Boolean;
- begin
- if Sender.fDragging then
- begin
- Stop := FALSE;
- case Msg.message of
- WM_MOUSEMOVE:
- CallDragCallBack( Sender, Stop );
- WM_LBUTTONUP, WM_RBUTTONUP:
- begin
- Stop := TRUE;
- CallDragCallBack( Sender, Stop );
- end;
- else
- begin
- Result := FALSE;
- Exit;
- end;
- end;
- if Stop then
- begin
- ReleaseCapture;
- Sender.fDragging := FALSE;
- end
- else
- begin
- Result := TRUE;
- exit;
- end;
- end;
- Result := FALSE;
- end;
-
- //[procedure TControl.DragItem]
- procedure TControl.DragItem(OnDrag: TOnDrag);
- begin
- fDragCallback := OnDrag;
- fDragging := TRUE;
- SetCapture( GetWindowHandle );
- AttachProc( WndProcDrag );
- end;
-
- {-}
- {$IFDEF USE_CONSTRUCTORS} //****************************************************//
- //
- //[constructor TControl.CreateWindowed]
- constructor TControl.CreateWindowed(AParent: PControl; AClassName: PKOLChar; //
- ACtl3D: Boolean); //
- begin //
- CreateParented( AParent ); //
- fOnDynHandlers := WndProcDummy; //
- fWndProcKeybd := WndProcDummy; //
- fWndProcResizeFlicks := WndProcDummy; //
- fCommandActions.aClear := ClearText; //
- //fWindowed := True; // is set in TControl.Init
- fControlClassName := AClassName; //
- //
- fControlClick := DummyObjProc; //
- //
- fColor := clBtnFace; //
- fTextColor := clWindowText; //
- fMargin := 2; //
- fCtl3D := True; //
- fCtl3Dchild := True; //
- if AParent <> nil then //
- begin //
- fWndProcResizeFlicks := AParent.fWndProcResizeFlicks; //
- fGotoControl := AParent.fGotoControl; //
- fDoubleBuffered := AParent.fDoubleBuffered; //
- fTransparent := AParent.fTransparent; //
- fCtl3Dchild := AParent.fCtl3Dchild; //
- if AParent.fCtl3Dchild then //
- fCtl3D := ACtl3D //
- else //
- fCtl3D := False; //
- fMargin := AParent.fMargin; //
- with fBoundsRect do //
- begin //
- Left := AParent.fMargin + AParent.fClientLeft; //
- Top := AParent.fMargin + AParent.fClientTop; //
- Right := Left + 64; //
- Bottom := Top + 64; //
- end; //
- fTextColor := AParent.fTextColor; //
- fFont := fFont.Assign( AParent.fFont ); //
- if fFont <> nil then //
- begin //
- fFont.fOnChange := FontChanged; //
- FontChanged( fFont ); //
- end; //
- fColor := AParent.fColor; //
- fBrush := fBrush.Assign( AParent.fBrush ); //
- if fBrush <> nil then //
- begin //
- fBrush.fOnChange := BrushChanged; //
- BrushChanged( fBrush ); //
- end; //
- end; //
- end; //
- //
- //[constructor TControl.CreateApplet]
- constructor TControl.CreateApplet(const ACaption: String); //
- begin //
- AppButtonUsed := True; //
- CreateWindowed( nil, 'App', TRUE ); //
- FIsApplet := TRUE; //
- fStyle := WS_VISIBLE or WS_SYSMENU or WS_POPUP or WS_MINIMIZEBOX //
- or WS_CAPTION; //
- fExStyle := WS_EX_APPWINDOW; //
- FCreateWndExt := CreateAppButton; //
- AttachProc( WndProcApp ); //
- Caption := ACaption; //
- end; //
- //
- //[constructor TControl.CreateForm]
- constructor TControl.CreateForm(AParent: PControl; const ACaption: String); //
- begin //
- CreateWindowed( AParent, 'Form', TRUE ); //
- AttachProc( WndProcForm ); //
- AttachProc( WndProcDoEraseBkgnd ); //
- Caption := ACaption; //
- end; //
- //
- //[constructor TControl.CreateControl]
- constructor TControl.CreateControl(AParent: PControl; AClassName: PChar; //
- AStyle: DWORD; ACtl3D: Boolean; Actions: PCommandActions); //
- var Form: PControl; //
- begin //
- CreateWindowed( AParent, AClassName, ACtl3D ); //
- if Actions <> nil then //
- fCommandActions := Actions^; //
- fIsControl := True; //
- fStyle := AStyle or WS_CLIPSIBLINGS or WS_CLIPCHILDREN; //
- fVisible := (Style and WS_VISIBLE) <> 0; //
- fTabstop := (Style and WS_TABSTOP) <> 0; //
- if (AParent <> nil) then //
- begin //
- Inc( AParent.ParentForm.fTabOrder ); //
- fTabOrder := AParent.ParentForm.fTabOrder; //
- end; //
- fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ]; //
- if fCtl3D then //
- begin //
- fStyle := fStyle and not WS_BORDER; //
- fExStyle := fExStyle or WS_EX_CLIENTEDGE; //
- end; //
- if (Style and WS_TABSTOP) <> 0 then //
- begin //
- Form := ParentForm; //
- if Form <> nil then //
- if Form.FCurrentControl = nil then //
- Form.FCurrentControl := @Self; //
- end; //
- //fCreateParamsExt := CreateParams2; //
- fMenu := CtlIdCount; //
- Inc( CtlIdCount ); //
- AttachProc( WndProcCtrl ); //
- end; //
- //
- //[constructor TControl.CreateButton]
- constructor TControl.CreateButton(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateControl( AParent, 'BUTTON', //
- WS_VISIBLE or WS_CHILD or //
- BS_PUSHLIKE or WS_TABSTOP, False, @ButtonActions ); //
- with fBoundsRect do //
- Bottom := Top + 22; //
- fTextAlign := taCenter; //
- Caption := ACaption; //
- end; //
- //
- //[constructor TControl.CreateBitBtn]
- constructor TControl.CreateBitBtn(AParent: PControl; //
- const ACaption: String; AOptions: TBitBtnOptions; ALayout: TGlyphLayout; //
- AGlyphBitmap: HBitmap; AGlyphCount: Integer); //
- var //
- B: TBitmapInfo; //
- W, H: Integer; //
- begin //
- CreateControl( AParent, 'BUTTON', WS_VISIBLE or WS_CHILD or //
- WS_TABSTOP or BS_OWNERDRAW, False, @ButtonActions ); //
- fBitBtnOptions := AOptions; //
- fGlyphLayout := ALayout; //
- fGlyphBitmap := AGlyphBitmap; //
- with fBoundsRect do //
- begin //
- Bottom := Top + 22; //
- W := 0; H := 0; //
- if AGlyphBitmap <> 0 then //
- begin //
- if bboImageList in AOptions then //
- ImageList_GetIconSize( AGlyphBitmap, W, H ) //
- else //
- begin //
- if GetObject( AGlyphBitmap, Sizeof(B), @B ) > 0 then //
- begin //
- W := B.bmiHeader.biWidth; //
- H := B.bmiHeader.biHeight; //
- if AGlyphCount = 0 then //
- AGlyphCount := W div H; //
- if AGlyphCount > 1 then //
- W := W div AGlyphCount; //
- end; //
- end; //
- if W > 0 then //
- if ACaption = '' then //
- Right := Left + W //
- else //
- Right := Right + W; //
- if H > 0 then //
- Bottom := Top + H; //
- if not ( bboNoBorder in AOptions ) then //
- begin //
- if W > 0 then //
- Inc( Right, 2 ); //
- if H > 0 then //
- Inc( Bottom, 2 ); //
- end; //
- end; //
- fGlyphWidth := W; //
- fGlyphHeight := H; //
- end; //
- fGlyphCount := AGlyphCount; //
- if AParent <> nil then //
- AParent.AttachProc( WndProc_DrawItem ); //
- AttachProc( WndProcBitBtn ); //
- fTextAlign := taCenter; //
- Caption := ACaption; //
- end; //
- //
- //[constructor TControl.CreateLabel]
- constructor TControl.CreateLabel(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
- SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, //
- False, @LabelActions ); //
- fIsStaticControl := 1; //
- fSizeRedraw := True; //
- fBoundsRect.Bottom := fBoundsRect.Top + 22; //
- Caption := ACaption; //
- end; //
- //
- //[constructor TControl.CreateWordWrapLabel]
- constructor TControl.CreateWordWrapLabel(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateLabel( AParent, ACaption ); //
- fBoundsRect.Bottom := fBoundsRect.Top + 44; //
- fStyle := fStyle and not SS_LEFTNOWORDWRAP; //
- end; //
- //
- //[constructor TControl.CreateLabelEffect]
- constructor TControl.CreateLabelEffect(AParent: PControl; ACaption: String; //
- AShadowDeep: Integer); //
- begin //
- CreateLabel( AParent, ACaption ); //
- fIsStaticControl := 0; //
- AttachProc( WndProcLabelEffect ); //
- fTextAlign := taCenter; //
- fTextColor := clBtnShadow; //
- fShadowDeep := AShadowDeep; //
- fIgnoreWndCaption := True; //
- with fBoundsRect do //
- begin //
- Bottom := Top + 40; //
- end; //
- end; //
- //
- //[constructor TControl.CreatePaintBox]
- constructor TControl.CreatePaintBox(AParent: PControl); //
- begin //
- CreateLabel( AParent, '' ); //
- with fBoundsRect do //
- begin //
- Right := Left + 40; //
- Bottom := Top + 40; //
- end; //
- end; //
- //
- {$IFDEF ASM_VERSION} //
- //[constructor TControl.CreateGradientPanel]
- constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
- AColor2: TColor); //
- asm //cmd //opd //
- XOR EDX, EDX //
- PUSH EDX //
- CALL CreateLabel //
- MOV ECX, AColor1 //
- MOV [EAX].fColor1, ECX //
- MOV ECX, AColor2 //
- MOV [EAX].fColor2, ECX //
- MOV EDX, [EAX].fBoundsRect.Left //
- ADD EDX, 40 //
- MOV [EAX].fBoundsRect.Right, EDX //
- MOV EDX, [EAX].fBoundsRect.Top //
- ADD EDX, 40 //
- MOV [EAX].fBoundsRect.Bottom, EDX //
- PUSH EAX //
- MOV EDX, offset[ WndProcGradient ] //
- CALL AttachProc //
- POP EAX //
- end; //
- {$ELSE ASM_VERSION} //Pascal //
- constructor TControl.CreateGradientPanel(AParent: PControl; AColor1, //
- AColor2: TColor); //
- begin //
- CreateLabel( AParent, '' ); //
- AttachProc( WndProcGradient ); //
- fColor2 := AColor2; //
- fColor1 := AColor1; //
- with fBoundsRect do //
- begin //
- Right := Left + 40; //
- Bottom := Top + 40; //
- end; //
- end; //
- {$ENDIF ASM_VERSION} //
- //
- //[constructor TControl.CreateGradientPanelEx]
- constructor TControl.CreateGradientPanelEx(AParent: PControl; AColor1, //
- AColor2: TColor; AStyle: TGradientStyle; ALayout: TGradientLayout); //
- begin //
- CreateLabel( AParent, '' ); //
- AttachProc( WndProcGradientEx ); //
- fColor2 := AColor2; //
- fColor1 := AColor1; //
- fGradientStyle := AStyle; //
- fGradientLayout := ALayout; //
- with fBoundsRect do //
- begin //
- Right := Left + 40; //
- Bottom := Top + 40; //
- end; //
- end; //
- //
- //[constructor TControl.CreateGroupbox]
- constructor TControl.CreateGroupbox(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateButton( AParent, ACaption ); //
- with fBoundsRect do //
- begin //
- Right := Left + 100; //
- Bottom := Top + 100; //
- end; //
- fStyle := WS_VISIBLE or WS_CHILD or BS_GROUPBOX or WS_TABSTOP; //
- fClientTop := 22; //
- fClientLeft := 2; //
- fClientBottom := 2; //
- fClientRight := 2; //
- fTabstop := False; //
- end; //
- //
- //[constructor TControl.CreateCheckbox]
- constructor TControl.CreateCheckbox(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateButton( AParent, ACaption ); //
- with fBoundsRect do //
- begin //
- Right := Left + 72; //
- end; //
- fStyle := WS_VISIBLE or WS_CHILD or //
- BS_AUTOCHECKBOX or WS_TABSTOP; //
- end; //
- //
- //[constructor TControl.CreateRadiobox]
- constructor TControl.CreateRadiobox(AParent: PControl; //
- const ACaption: String); //
- begin //
- CreateCheckbox( AParent, ACaption ); //
- fStyle := WS_VISIBLE or WS_CHILD or //
- BS_RADIOBUTTON or WS_TABSTOP or WS_GROUP; //
- fControlClick := ClickRadio; //
- if AParent <> nil then //
- begin //
- AParent.fRadioLast := fMenu; //
- if AParent.fRadio1st = 0 then //
- begin //
- AParent.fRadio1st := fMenu; //
- SetRadioChecked; //
- end; //
- end; //
- end; //
- //
- //[constructor TControl.CreateEditbox]
- constructor TControl.CreateEditbox(AParent: PControl; //
- AOptions: TEditOptions); //
- var Flags: Integer; //
- begin //
- Flags := MakeFlags( @AOptions, EditFlags ); //
- if not(eoMultiline in AOptions) then //
- Flags := Flags and not(WS_HSCROLL or WS_VSCROLL); //
- CreateControl( AParent, 'EDIT', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
- or WS_BORDER or Flags, True, @EditActions ); //
- //YS fCursor := LoadCursor( 0, IDC_IBEAM ); // //YS
- with fBoundsRect do //
- begin //
- Right := Left + 100; //
- Bottom := Top + 22; //
- if eoMultiline in AOptions then //
- begin //
- Right := Right + 100; //
- Bottom := Top + 200; //
- end; //
- end; //
- fColor := clWindow; //
- fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ]; //
- if eoMultiline in AOptions then //
- fLookTabKeys := [ tkTab ]; //
- if eoWantTab in AOptions then //
- fLookTabKeys := fLookTabKeys - [ tkTab ]; //
- end; //
- //
- //[constructor TControl.CreatePanel]
- constructor TControl.CreatePanel(AParent: PControl; AStyle: TEdgeStyle); //
- const Edgestyles: array[ TEdgeStyle ] of DWORD = ( WS_DLGFRAME, SS_SUNKEN, 0 ); //
- begin //
- CreateControl( AParent, 'STATIC', WS_VISIBLE or WS_CHILD or //
- SS_LEFTNOWORDWRAP or SS_NOPREFIX or SS_NOTIFY, False, //
- @LabelActions ); //
- with fBoundsRect do //
- begin //
- Right := Left + 100; //
- Bottom := Top + 100; //
- end; //
- Style := Style or Edgestyles[ AStyle ]; //
- ExStyle := ExStyle or WS_EX_CONTROLPARENT; //
- end; //
- //
- //[constructor TControl.CreateSplitter]
- constructor TControl.CreateSplitter(AParent: PControl; AMinSizePrev, //
- AMinSizeNext: Integer; EdgeStyle: TEdgeStyle); //
- var PrevCtrl: PControl; //
- Sz0: Integer; //
- begin //
- CreatePanel( AParent, EdgeStyle ); //
- fSplitMinSize1 := AMinSizePrev; //
- fSplitMinSize2 := AMinSizeNext; //
- Sz0 := 4; //
- with fBoundsRect do //
- begin //
- Right := Left + Sz0; //
- Bottom := Top + Sz0; //
- end; //
- if AParent <> nil then //
- begin //
- if AParent.fChildren.fCount > 1 then //
- begin //
- PrevCtrl := AParent.fChildren.fItems[ AParent.fChildren.fCount - 2 ]; //
- case PrevCtrl.FAlign of //
- caLeft, caRight: //
- begin //
- fCursor := LoadCursor( 0, IDC_SIZEWE ); //
- end; //
- caTop, caBottom: //
- begin //
- fCursor := LoadCursor( 0, IDC_SIZENS ); //
- end; //
- end; //
- Align := PrevCtrl.FAlign; //
- end; //
- end; //
- AttachProc( WndProcSplitter ); //
- end; //
- //
- //[constructor TControl.CreateListbox]
- constructor TControl.CreateListbox(AParent: PControl; //
- AOptions: TListOptions); //
- var Flags: Integer; //
- begin //
- Flags := MakeFlags( @AOptions, ListFlags ); //
- CreateControl( AParent, 'LISTBOX', WS_VISIBLE or WS_CHILD or WS_TABSTOP //
- or WS_BORDER or WS_VSCROLL //
- or LBS_NOTIFY or Flags, True, @ListActions ); //
- with fBoundsRect do //
- begin //
- Right := Right + 100; //
- Bottom := Top + 200; //
- end; //
- fColor := clWindow; //
- fLookTabKeys := [ tkTab, tkLeftRight ]; //
- end; //
- //
- //[constructor TControl.CreateCombobox]
- constructor TControl.CreateCombobox(AParent: PControl; //
- AOptions: TComboOptions); //
- var Flags: Integer; //
- begin //
- Flags := MakeFlags( @AOptions, ComboFlags ); //
- CreateControl( AParent, 'COMBOBOX', //
- WS_VISIBLE or WS_CHILD or WS_VSCROLL or //
- CBS_DROPDOWN or CBS_HASSTRINGS or WS_TABSTOP or Flags, //
- True, @ComboActions ); //
- fCreateWndExt := CreateComboboxWnd; //
- fDropDownProc := ComboboxDropDown; //
- fClsStyle := fClsStyle or CS_DBLCLKS; //
- with fBoundsRect do //
- begin //
- Right := Left + 100; //
- Bottom := Top + 22; //
- end; //
- fColor := clWindow; //
- fLookTabKeys := [ tkTab ]; //
- if coReadOnly in AOptions then //
- fLookTabKeys := [ tkTab, tkLeftRight ]; //
- end; //
- //
- //[constructor TControl.CreateCommonControl]
- constructor TControl.CreateCommonControl(AParent: PControl; //
- AClassName: PChar; AStyle: DWORD; ACtl3D: Boolean; //
- Actions: PCommandActions); //
- begin //
- {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
- CreateControl( AParent, AClassName, AStyle, ACtl3D, Actions ); //
- fIsCommonControl := True; //
- if AParent <> nil then //
- begin //
- AttachProc( WndProcParentResize ); //
- AParent.AttachProc( WndProcResize ); //
- AttachProc( WndProcCommonNotify ); //
- AParent.AttachProc( WndProcNotify ); //
- end; //
- end; //
- //
- //[constructor TControl.CreateRichEdit1]
- constructor TControl.CreateRichEdit1(AParent: PControl; //
- AOptions: TEditOptions); //
- var Flags, I: Integer; //
- begin //
- if FRichEditModule = 0 then //
- begin //
- for I := 0 to High( RichEditLibnames ) do //
- begin //
- FRichEditModule := LoadLibrary( RichEditLibnames[ I ] ); //
- if FRichEditModule > HINSTANCE_ERROR then break; //
- RichEditClass := RichEditClasses[ I ]; //
- end; //
- if FRichEditModule <= HINSTANCE_ERROR then //
- FRichEditModule := 0; //
- end; //
- Flags := MakeFlags( @AOptions, RichEditFlags ); //
- CreateCommonControl( AParent, RichEditClass, WS_VISIBLE or WS_CHILD //
- or WS_TABSTOP or WS_BORDER or ES_MULTILINE or Flags, //
- True, @RichEditActions ); //
- //
- AttachProc( WndProcRichEditNotify ); //
- fDoubleBuffered := False; //
- fCannotDoubleBuf := True; //
- with fBoundsRect do //
- begin //
- Right := Right + 100; //
- Bottom := Top + 200; //
- end; //
- fColor := clWindow; //
- fLookTabKeys := [ tkTab ]; //
- if eoWantTab in AOptions then //
- fLookTabKeys := [ ]; //
- Perform( EM_SETEVENTMASK, 0, //
- ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or //
- ENM_PROTECTED or $04000000 {ENM_LINK} ); //
- Perform( EM_SETBKGNDCOLOR, 0, Color2RGB(fColor)); //
- end; //
- //
- //
- //[constructor TControl.CreateRichEdit]
- constructor TControl.CreateRichEdit(AParent: PControl; //
- AOptions: TEditOptions); //
- var OldRichEditClass, OldRichEditLib: PChar; //
- begin //
- if OleInit then //
- begin //
- OldRichEditClass := RichEditClass; //
- OldRichEditLib := RichEditLib; //
- CreateRichEdit1( AParent, AOptions ); //
- fCharFmtDeltaSz := 24; //
- fParaFmtDeltaSz := sizeof( TParaFormat2 ) - sizeof( RichEdit.TParaFormat ); //
- RichEditClass := OldRichEditClass; //
- RichEditLib := OldRichEditLib; //
- end //
- else //
- CreateRichEdit1( AParent, AOptions ); //
- end; //
- //
- //[constructor TControl.CreateProgressbar]
- constructor TControl.CreateProgressbar(AParent: PControl); //
- const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
- (PBS_VERTICAL, PBS_SMOOTH ); //
- begin //
- CreateCommonControl( AParent, PROGRESS_CLASS, //
- WS_CHILD or WS_VISIBLE, True, nil ); //
- with fBoundsRect do //
- begin //
- Right := Left + 300; //
- Bottom := Top + 20; //
- end; //
- fMenu := 0; //
- fTextColor := clHighlight; //
- end; //
- //
- //[constructor TControl.CreateProgressbarEx]
- constructor TControl.CreateProgressbarEx(AParent: PControl; //
- AOptions: TProgressbarOptions); //
- const ProgressBarFlags: array[ TProgressbarOption ] of Integer = //
- (PBS_VERTICAL, PBS_SMOOTH ); //
- begin //
- CreateProgressbar( AParent ); //
- fStyle := fStyle or DWORD( MakeFlags( @AOptions, ProgressBarFlags ) ); //
- end; //
- //
- //[constructor TControl.CreateListView]
- constructor TControl.CreateListView(AParent: PControl; //
- AStyle: TListViewStyle; AOptions: TListViewOptions; AImageListSmall, //
- AImageListNormal, AImageListState: PImageList); //
- begin //
- CreateCommonControl( AParent, WC_LISTVIEW, ListViewStyles[ AStyle ] or //
- LVS_SHAREIMAGELISTS or WS_CHILD or WS_VISIBLE or WS_TABSTOP, //
- True, @ListViewActions ); //
- fLVOptions := AOptions; //
- fLVStyle := AStyle; //
- fCreateWndExt := ApplyImageLists2ListView; //
- with fBoundsRect do //
- begin //
- Right := Left + 200; //
- Bottom := Top + 150; //
- end; //
- ImageListSmall := AImageListSmall; //
- ImageListNormal := AImageListNormal; //
- ImageListState := AImageListState; //
- fLVTextBkColor := clWindow; //
- fLookTabKeys := [ tkTab ]; //
- end; //
- //
- //[constructor TControl.CreateTreeView]
- constructor TControl.CreateTreeView(AParent: PControl; //
- AOptions: TTreeViewOptions; AImgListNormal, AImgListState: PImageList); //
- var Flags: Integer; //
- begin //
- Flags := MakeFlags( @AOptions, TreeViewFlags ); //
- CreateCommonControl( AParent, WC_TREEVIEW, Flags or WS_VISIBLE or //
- WS_CHILD or WS_TABSTOP, True, @TreeViewActions ); //
- fCreateWndExt := ApplyImageLists2Control; //
- fColor := clWindow; //
- AttachProc( WndProcTreeView ); //
- with fBoundsRect do //
- begin //
- Right := Left + 150; //
- Bottom := Top + 200; //
- end; //
- ImageListNormal := AImgListNormal; //
- ImageListState := AImgListState; //
- fLookTabKeys := [ tkTab ]; //
- end; //
- //
- //[constructor TControl.CreateTabControl]
- constructor TControl.CreateTabControl(AParent: PControl; ATabs: array of String;//
- AOptions: TTabControlOptions; //
- AImgList: PImageList; AImgList1stIdx: Integer); //
- var I, II : Integer; //
- Flags: Integer; //
- begin //
- Flags := MakeFlags( @AOptions, TabControlFlags ); //
- if tcoFocusTabs in AOptions then //
- Flags := Flags or (WS_TABSTOP or TCS_FOCUSONBUTTONDOWN); //
- CreateCommonControl( AParent, WC_TABCONTROL, //
- Flags or (WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or //
- WS_VISIBLE), True, @TabControlActions ); //
- if not( tcoBorder in AOptions ) then //
- fExStyle := fExStyle and not WS_EX_CLIENTEDGE; //
- AttachProc( WndProcTabControl ); //
- with fBoundsRect do //
- begin //
- Right := Left + 100; //
- Bottom := Top + 100; //
- end; //
- if AImgList <> nil then //
- Perform( TCM_SETIMAGELIST, 0, AImgList.Handle ); //
- II := AImgList1stIdx; //
- for I := 0 to High( ATabs ) do //
- begin //
- TC_Insert( I, ATabs[ I ], II ); //
- Inc( II ); //
- end; //
- fLookTabKeys := [ tkTab ]; //
- end; //
- //
- //[constructor TControl.CreateToolbar]
- constructor TControl.CreateToolbar(AParent: PControl; //
- AAlign: TControlAlign; AOptions: TToolbarOptions; ABitmap: HBitmap; //
- AButtons: array of PChar; ABtnImgIdxArray: array of Integer); //
- var Flags: DWORD; //
- begin //
- if not( tboTextBottom in AOptions ) then //
- AOptions := AOptions + [ tboTextRight ]; //
- if tboTextRight in AOptions then //
- AOptions := AOptions - [ tboTextBottom ]; //
- Flags := MakeFlags( @AOptions, ToolbarOptions ); //
- CreateCommonControl( AParent, TOOLBARCLASSNAME, ToolbarAligns[ Align ] or //
- WS_CHILD or WS_VISIBLE {or WS_TABSTOP} //
- or TBSTYLE_TOOLTIPS or Flags, //
- (not (Align in [caNone])) and //
- not (tboNoDivider in AOptions), nil ); //
- fCommandActions.aClear := ClearToolbar; //
- fCommandActions.aGetCount := TB_BUTTONCOUNT; //
- with fBoundsRect do //
- begin //
- if AAlign in [ caNone ] then //
- begin //
- Bottom := Top + 26; //
- Right := Left + 1000; //
- end //
- else //
- begin //
- Left := 0; Right := 0; //
- Top := 0; Bottom := 0; //
- end; //
- end; //
- Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or //
- TBSTYLE_EX_DRAWDDARROWS); //
- //
- AttachProc( WndProcToolbarCtrl ); //
- Perform( TB_BUTTONSTRUCTSIZE, Sizeof( TTBButton ), 0 ); //
- Perform( TB_SETINDENT, fMargin, 0 ); //
- with fBoundsRect do //
- begin //
- if AAlign in [ caLeft, caRight ] then //
- Right := Left + 24 //
- else if not (AAlign in [caNone]) then //
- Bottom := Top + 22; //
- end; //
- if ABitmap <> 0 then //
- TBAddBitmap( ABitmap ); //
- TBAddButtons( AButtons, ABtnImgIdxArray ); //
- Perform( WM_SIZE, 0, 0 ); //
- end; //
- //
- //[constructor TImageList.CreateImageList]
- constructor TImageList.CreateImageList(POwner: Pointer); //
- var AOwner: PControl; //
- begin //
- {*************} DoInitCommonControls( ICC_WIN95_CLASSES ); //
- Create; //
- FAllocBy := 1; //
- FMasked := True; //
- if POwner = nil then exit; //
- FBkColor := TColor( CLR_NONE );
- //ImageList_SetBkColor( FHandle, CLR_NONE );
- //
- AOwner := POwner; //
- FControl := AOwner; //
- fNext := PImageList( AOwner.fImageList ); //
- if AOwner.fImageList <> nil then //
- PImageList( AOwner.fImageList ).fPrev := @Self; //
- AOwner.fImageList := @Self; //
- end; //
- //
- //[constructor TThread.ThreadCreate]
- constructor TThread.ThreadCreate; //
- begin //
- IsMultiThread := True; //
- Create; //
- FSuspended := True; //
- FHandle := CreateThread( nil, // no security //
- 0, // the same stack size //
- @ThreadFunc, // thread entry point //
- @Self, // parameter to pass to ThreadFunc //
- CREATE_SUSPENDED, // always SUSPENDED //
- FThreadID ); // receive thread ID //
- end; //
- //
- //[constructor TThread.ThreadCreateEx]
- constructor TThread.ThreadCreateEx( const Proc: TOnThreadExecute ); //
- begin //
- ThreadCreate; //
- OnExecute := Proc; //
- Resume; //
- end; //
- //
- {$ENDIF USE_CONSTRUCTORS} //****************************************************//
- {+}
-
- //[procedure InvalidateExW]
- procedure InvalidateExW( Wnd: HWnd );
- begin
- InvalidateRect( Wnd, nil, TRUE );
- Wnd := GetWindow( Wnd, GW_CHILD );
- while Wnd <> 0 do
- begin
- InvalidateExW( Wnd );
- Wnd := GetWindow( Wnd, GW_HWNDNEXT );
- end;
- end;
-
- //[procedure TControl.InvalidateEx]
- procedure TControl.InvalidateEx;
- begin
- if fHandle = 0 then Exit;
- InvalidateExW( fHandle );
- end;
-
- //[procedure InvalidateNCW]
- procedure InvalidateNCW( Wnd: HWnd; Recursive: Boolean );
- begin
- SendMessage( Wnd, WM_NCPAINT, 1, 0 );
- if not Recursive then Exit;
- Wnd := GetWindow( Wnd, GW_CHILD );
- while Wnd <> 0 do
- begin
- InvalidateNCW( Wnd, Recursive );
- Wnd := GetWindow( Wnd, GW_HWNDNEXT );
- end;
- end;
-
- //[procedure TControl.InvalidateNC]
- procedure TControl.InvalidateNC(Recursive: Boolean);
- begin
- if fHandle = 0 then Exit;
- InvalidateNCW( fHandle, Recursive );
- end;
-
- //[procedure TControl.SetClientMargin]
- procedure TControl.SetClientMargin(const Index, Value: Integer);
- begin
- case Index of
- 1: fClientTop := Value;
- 2: fClientBottom := Value;
- 3: fClientLeft := Value;
- 4: fClientRight := Value;
- end;
- {$IFNDEF OLD_ALIGN}include(fAligning,oaFromSelf);{$ENDIF}//???
- Global_Align( @Self );
- end;
-
- {$IFDEF F_P}
- //[function TControl.GetClientMargin]
- function TControl.GetClientMargin(const Index: Integer): Integer;
- begin
- CASE Index OF
- 1: Result := fClientTop;
- 2: Result := fClientBottom;
- 3: Result := fClientLeft;
- 4: Result := fClientRight;
- END;
- end;
- {$ENDIF F_P}
-
- {------------------------------------------------------------------------------}
-
- { G R A P H C O N T R O L S }
-
- {------------------------------------------------------------------------------}
- type TGrayTextData = {$ifndef wince}packed{$endif} record
- Ctl: PControl;
- W, H: Integer;
- Flags: DWORD;
- end;
- PGrayTextData = ^TGrayTextData;
-
- function DrawTextGrayed( DC: HDC; lData, wData, cX, cY: Integer ): BOOL; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var GDT: PGrayTextData;
- R: TRect;
- begin
- GDT := Pointer( lData );
- R := MakeRect( 0, 0, cX, cY );
- DrawFormattedText( GDT.Ctl, DC, R, GDT.Flags or $80000000 );
- Result := TRUE;
- end;
-
- procedure DrawFormattedText( Ctl: PControl; DC: HDC; var R: TRect; Flags: DWORD {EditCtl: Boolean} );
- var Fmt: DWORD;
- OldFont: Integer;
- OldBrush: Integer;
- OldBk: Integer;
- ParentHavingFont: PControl;
- {$ifdef win32}
- GTD: TGrayTextData;
- {$endif win32}
- dX, dY: Integer;
- R1: TRect;
- begin
- Fmt := DT_EXPANDTABS or Flags and $7FFFFFFF;
- if Ctl.WordWrap then
- Fmt := Fmt or DT_WORDBREAK;
- if Flags and DT_EDITCONTROL <> 0 then
- Inc( R.Left, 4 );
-
- ParentHavingFont := Ctl;
- while (ParentHavingFont <> nil) and not Assigned( ParentHavingFont.FFont )
- and not ParentHavingFont.IsForm do
- ParentHavingFont := ParentHavingFont.Parent;
- OldFont := 0;
- if Assigned( ParentHavingFont ) then
- begin
- OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
- SetTextColor( DC, ParentHavingFont.Font.FColorRGB );
- end;
-
- R1 := R;
- Windows.{$IFDEF UNICODE_CTRLS}DrawTextW{$ELSE}DrawTextA{$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R,
- Fmt or DT_CALCRECT );
- CASE Ctl.fTextAlign OF
- taCenter:
- dX := (R1.Right - R1.Left - (R.Right - R.Left)) div 2;
- taRight:
- dX := R1.Right - R.Right;
- else
- dX := 0;
- END;
- CASE Ctl.fVerticalAlign OF
- vaCenter:
- dY := (R1.Bottom - R1.Top - (R.Bottom - R.Top)) div 2;
- vaBottom:
- dY := R1.Bottom - R.Bottom;
- else
- dY := 0;
- END;
- OffsetRect( R, dX, dY );
-
- if Ctl.fEnabled or (Flags and $80000000 <> 0) then
- begin
- OldBk := SetBkMode( DC, TRANSPARENT );
- OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
- Windows.{$IFDEF UNICODE_CTRLS}DrawTextW{$ELSE}DrawTextA{$ENDIF}( DC, PKOLChar( Ctl.Caption ), Length( Ctl.Caption ), R, Fmt );
- SelectObject( DC, OldBrush );
- SetBkMode( DC, OldBk );
- end
- else
- begin
- {$ifdef wince}
- MsgOk('DrawFormattedText must be fixed!');
- Halt(4); // FIXME
- {$else}
- GTD.Ctl := Ctl;
- GTD.W := R.Right - R.Left;
- GTD.H := R.Bottom - R.Top;
- GTD.Flags := Flags;
- Windows.DrawState( DC, GetStockObject( NULL_BRUSH ), @ DrawTextGrayed,
- Integer( @ GTD ), Length( Ctl.fCaption ), R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
- DST_COMPLEX or DSS_DISABLED );
- {$endif wince}
- end;
- if Assigned( ParentHavingFont ) then
- SelectObject( DC, OldFont );
- end;
-
- {$IFDEF USE_GRAPHCTLS}
- {$IFDEF GRAPHCTL_XPSTYLES}
- type TOpenThemeDataProc = function( Wnd: HWnd; pszClassList: PWideChar ): THandle;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- TDrawThemeBackground = function( Theme: THandle; DC: HDC; iPartId: Integer;
- iStateId: Integer; Rect, ClipRect: PRect ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- TGetThemeBackgroundContentRect = function( Theme: THandle; DC: HDC;
- iPartId, iStateId: Integer; Rect, ContentRect: PRect ):
- Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- TDrawThemeText = function( Theme: THandle; DC: HDC; iPartId, iStateId: Integer;
- pszText: PWideChar; iCharCount: Integer;
- dwTextFlags, dwTextFlags2: DWORD; Rect: PRect ): Integer;
- {$ifdef wince}cdecl{$else}stdcall{$endif};
- TCloseThemeData = function( Theme: THandle ): Integer; {$ifdef wince}cdecl{$else}stdcall{$endif};
- var fOpenThemeDataProc: TOpenThemeDataProc;
- fDrawthemeBackground: TDrawThemeBackground;
- fGetThemeBackgroundcontentRect: TGetThemeBackgroundContentRect;
- fDrawThemeText: TDrawThemeText;
- fCloseThemeData: TCloseThemeData;
- uxtheme_lib: THandle;
- function OpenThemeDataProc: TOpenThemeDataProc;
- begin
- Result := nil;
- if Integer(uxtheme_lib) = -1 then Exit;
- if uxtheme_lib = 0 then
- uxtheme_lib := LoadLibrary( 'uxtheme' );
- if uxtheme_lib = 0 then
- begin
- uxtheme_lib := DWORD( -1 );
- Exit;
- end;
- fOpenThemeDataProc := GetProcAddress( uxtheme_lib, 'OpenThemeData' );
- fDrawthemeBackground := GetProcAddress( uxtheme_lib, 'DrawThemeBackground' );
- fGetThemeBackgroundcontentRect := GetProcAddress( uxtheme_lib, 'GetThemeBackgroundContentRect' );
- fDrawThemeText := GetProcAddress( uxtheme_lib, 'DrawThemeText' );
- fCloseThemeData := GetProcAddress( uxtheme_lib, 'CloseThemeData' );
- if not Assigned( fOpenThemeDataProc ) or
- not Assigned( fDrawThemeBackground ) or
- not Assigned( fGetThemeBackgroundcontentRect ) or
- not Assigned( fDrawThemeText ) or
- not Assigned( fCloseThemeData ) then
- begin
- FreeLibrary( uxtheme_lib );
- uxtheme_lib := DWORD( -1 );
- fOpenThemeDataProc := nil;
- fDrawThemeBackground := nil;
- fGetThemeBackgroundcontentRect := nil;
- fDrawThemeText := nil;
- fCloseThemeData := nil;
- end;
- Result := fOpenThemeDataProc;
- end;
-
- procedure DrawFormattedTextXP( Theme: THandle; Ctl: PControl; DC: HDC;
- var R: TRect; CtlType, CtlStates, Flags1, Flags2: Integer );
- var OldFont: Integer;
- OldBrush: Integer;
- ParentHavingFont: PControl;
- begin
- ParentHavingFont := Ctl;
- while (ParentHavingFont <> nil) and not Assigned( ParentHavingFont.FFont )
- and not ParentHavingFont.IsForm do
- ParentHavingFont := ParentHavingFont.Parent;
- OldFont := 0;
- if Assigned( ParentHavingFont ) then
- OldFont := SelectObject( DC, ParentHavingFont.Font.Handle );
- OldBrush := SelectObject( DC, GetStockObject( NULL_BRUSH ) );
- fDrawThemeText( Theme, DC, CtlType, CtlStates, @ WideString( Ctl.fCaption )[ 1 ],
- Length( Ctl.fCaption ), Flags1, Flags2, @ R );
- SelectObject( DC, OldBrush );
- if Assigned( ParentHavingFont ) then
- SelectObject( DC, OldFont );
- end;
- {$ENDIF}
-
- procedure PaintGraphicChildren( Self_, Sender: PControl; DC: HDC );
- var i, sav: Integer;
- C: PControl;
- R: TRect;
- rgn: HRgn;
- begin
- for i := Self_.ChildCount-1 downto 0 do
- begin
- C := Self_.Children[ i ];
- if not C.Visible then continue;
- R := C.BoundsRect;
- if (C.Handle = 0) and not C.fWindowed and
- Assigned( C.fPaintProc ) then
- begin
- sav := SaveDC( DC );
- rgn := CreateRectRgnIndirect( R );
- ExtSelectClipRgn( DC, rgn, RGN_AND );
- SelectClipRgn( DC, rgn );
- DeleteObject( rgn );
- Free_And_Nil( C.fCanvas );
-
- C.fCanvas := Self_.Canvas;
- Self_.Canvas.Brush.Assign( Self_.Brush );
- Self_.Canvas.Font.Assign( Self_.Font ); // íå ïðèñâàèâàåòñÿ?
- Self_.fCanvas.DeselectHandles; // íå ïîìîãàåò???
-
- if Assigned( C.OnPrepaint ) then
- C.OnPrePaint( C, DC );
-
- if Assigned( C.OnPaint ) then
- C.OnPaint( C, DC )
- else
- C.fPaintProc( DC );
-
- if Assigned( C.OnPostPaint ) then
- C.OnPostPaint( C, DC );
-
- C.fCanvas := nil;
-
- Self_.Canvas.Brush.Assign( Self_.Brush );
- Self_.Canvas.Font.Assign( Self_.Font );
-
- RestoreDC( DC, sav );
- ExcludeClipRect( DC, R.Left, R.Top, R.Right, R.Bottom );
- end;
- end;
- if Self_.fIsGroupBox then
- begin
- Self_.fErasingBkgnd := TRUE;
- R := Self_.BoundsRect;
- OffsetRect( R, -R.Left, -R.Top );
- Self_.Canvas.FillRect( R );
- Self_.GroupBoxPaint( DC );
- Self_.fErasingBkgnd := FALSE;
- end
- else
- if Assigned( Self_.fOnPaint2 ) then
- Self_.fOnPaint2( Self_, DC )
- else
- Self_.Canvas.FillRect( Self_.ClientRect );
- end;
-
- function WndProc_ParentOfGraphicCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var WasOnPaint: TOnPaint;
- i: Integer;
- C: PControl;
- Pt: TPoint;
- PF: PControl;
- save_Paint2: TOnPaint;
- begin
- Result := FALSE;
-
- if (Msg.message = WM_PAINT) {or (Msg.message = WM_PRINT)} then
- begin
- //if not Result then
- begin
- WasOnPaint := Self_.fOnPaint;
- Self_.fOnPaint2 := Self_.fOnPaint;
- Self_.fPaintMsg := Msg;
- TMethod( Self_.fOnPaint ) := MakeMethod( Self_, @ PaintGraphicChildren );
-
- save_Paint2 := Self_.fOnPaint2;
- if not Assigned( Self_.fOnPaint2 ) then
- Self_.fOnPaint2 := TOnPaint( MakeMethod( nil, @ DummyPaintClear ) );
-
- i := Self_.fDynHandlers.fCount;
- Self_.fDynHandlers.fCount := Self_.fDynHandlers.IndexOf( @ WndProc_ParentOfGraphicCtl );
- Result := EnumDynHandlers( Self_, Msg, Rslt );
- Self_.fDynHandlers.fCount := i;
-
- //Self_.fOnPaint2 := save_Paint2;
-
- if not Result then
- {Result :=} WndProcPaint( Self_, Msg, Rslt );
- Self_.fOnPaint := WasOnPaint;
- end;
- Result := TRUE;
- end
- else
- if (Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST) then
- begin
- Pt.X := SmallInt( LoWord( Msg.lParam ) );
- Pt.Y := SmallInt( HiWord( Msg.lParam ) );
- for i := 0 to Self_.ChildCount-1 do
- begin
- if (i = 0) and (Self_.fPushedBtn <> nil) then
- C := Self_.fPushedBtn
- else
- C := Self_.Children[ i ];
- if (C = Self_.fPushedBtn) OR
- C.fVisible and C.fEnabled and PtInRect( C.BoundsRect, Pt ) then
- begin
- if not C.fWindowed and
- (C.fCursor <> 0) and (C.fCursor <> Self_.fCursor) and
- (ScreenCursor = 0) then
- begin
- if Self_.fSaveCursor = 0 then
- begin
- Self_.fSaveCursor := Self_.fCursor;
- if Self_.fCursor = 0 then
- Self_.fSaveCursor := LoadCursor( 0, IDC_ARROW );
- end;
- Self_.Cursor := C.fCursor;
- Windows.SetCursor( C.fCursor );
- end;
- {$IFDEF GRAPHCTL_HOTTRACK}
- if not C.fWindowed and (Applet.fHotCtl <> C) then
- begin
- if Applet.fHotCtl <> nil then
- begin
- Applet.fHotCtl.fHot := FALSE;
- if not Applet.fHotCtl.fWindowed then
- begin
- Applet.fHotCtl.Invalidate;
- if Assigned( Applet.fHotCtl.OnMouseLeave ) then
- Applet.fHotCtl.OnMouseLeave( Applet.fHotCtl );
- end;
- Applet.fHotCtl.RefDec;
- end;
- C.RefInc;
- Applet.fHotCtl := C;
- C.fHot := TRUE;
- C.Invalidate;
- Self_.fMouseLeaveProc := Self_.MouseLeaveFromParentOfGraphCtl;
- ProvideMouseEnterLeave( Self_ );
- if Assigned( C.OnMouseEnter ) then
- C.OnMouseEnter( C );
- end;
- {$ENDIF GRAPHCTL_HOTTRACK}
- if C.fWindowed then
- begin
- Msg.hwnd := C.fHandle;
- Pt := Self_.Client2Screen( Pt );
- Pt := C.Screen2Client( Pt );
- Msg.lParam := Pt.Y shl 16 or (Pt.X and $FFFF);
- end;
- Rslt := C.WndProc( Msg );
- if not C.fWindowed then
- if Assigned( C.fGraphCtlMouseEvent ) then
- C.fGraphCtlMouseEvent( Msg )
- else
- if (Msg.message = WM_LBUTTONDOWN) or
- (Msg.message = WM_RBUTTONDOWN) or
- (Msg.message = WM_MBUTTONDOWN) then
- C.DoClick;
- Result := TRUE;
- Exit;
- end;
- end;
- {$IFDEF GRAPHCTL_HOTTRACK}
- Self_.MouseLeaveFromParentOfGraphCtl( Self_ );
- {$ENDIF GRAPHCTL_HOTTRACK}
- if Self_.fIsGroupBox and (
- (Msg.message = WM_LBUTTONDOWN) or
- (Msg.message = WM_LBUTTONDBLCLK) or
- (Msg.message = WM_LBUTTONUP)
- ) then
- begin
- Self_.Invalidate;
- end;
- if Self_.fSaveCursor <> 0 then
- begin
- Self_.Cursor := Self_.fSaveCursor;
- Self_.fSaveCursor := 0;
- if ScreenCursor = 0 then
- Windows.SetCursor( Self_.fCursor );
- end;
- end
- else
- if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
- begin
- if Self_.IsControl then
- PF := Self_.ParentForm
- else
- PF := Self_;
- if (PF.fCurrentControl <> nil) and not PF.fCurrentControl.fWindowed then
- begin
- if Assigned( PF.fCurrentControl.fKeyboardProcess ) and
- PF.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
- else
- Rslt := PF.fCurrentControl.WndProc( Msg );
- Result := TRUE;
- end
- else
- begin
- if Self_.fIsGroupBox and (Msg.wParam = WORD( ' ' )) and
- (
- (Msg.message = WM_KEYDOWN) or
- (Msg.message = WM_SYSKEYDOWN) or
- (Msg.message = WM_KEYUP) or
- (Msg.message = WM_SYSKEYUP) or
- (Msg.message = WM_CHAR) or
- (Msg.message = WM_SYSCHAR)
- ) then
- begin
- Self_.Invalidate;
- end;
- end;
- end
- else
- if Msg.message = CM_QUIT then
- begin
- C := Pointer( Msg.wParam );
- C.Free;
- end
- else
- if Msg.message = CM_FOCUSGRAPHCTL then
- begin
- C := Pointer( Msg.wParam );
- PF := C.ParentForm;
- if (PF.fCurrentControl <> nil) and (PF.fCurrentControl <> C) then
- begin
- PF.fCurrentControl.fFocused := FALSE;
- PF.fCurrentControl.Invalidate;
- end;
- PF.fCurrentControl := C;
- C.Parent.fCurrentControl := C;
- C.Parent.fFocusHandle := C.Parent.fHandle;
- C.fFocused := TRUE;
- if Assigned( C.fOnEnter ) then
- C.fOnEnter( C );
- C.Invalidate;
- C.fLeave := C.LeaveGraphButton;
- C.RefDec;
- end;
- end;
-
- function WndProc_FormHavingGraphCtl( Self_: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var Msg2: TMsg;
- begin
- Result := FALSE;
- if Msg.message = WM_ACTIVATE then
- begin
- if Self_.fCurrentControl <> nil then
- Self_.fCurrentControl.Invalidate;
- end
- else
- if (Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST) then
- begin
- if (Self_.fCurrentControl <> nil) and not Self_.fCurrentControl.fWindowed then
- begin
- if (Msg.message = WM_KEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
- begin
- if not PeekMessage( Msg2, Msg.hwnd, WM_CHAR, WM_CHAR, pm_noRemove ) or
- (Msg2.wParam <> Msg.wParam) then
- Msg.message := WM_CHAR;
- end
- else
- if (Msg.message = WM_SYSKEYDOWN) and ((Msg.wParam = 32) or (Msg.wParam = 13)) then
- begin
- if not PeekMessage( Msg2, Msg.hwnd, WM_SYSCHAR, WM_SYSCHAR, pm_noRemove ) or
- (Msg2.wParam <> Msg.wParam) then
- Msg.message := WM_SYSCHAR;
- end;
- if Assigned( Self_.fCurrentControl.fKeyboardProcess ) and
- Self_.fCurrentControl.fKeyboardProcess( Msg, Rslt ) then
- else
- Rslt := Self_.fCurrentControl.WndProc( Msg );
- Result := TRUE;
- end;
- end;
- end;
-
- {$IFDEF GRAPHCTL_HOTTRACK}
- procedure TControl.MouseLeaveFromParentOfGraphCtl(Sender: PObj);
- var C: PControl;
- Pt: TPoint;
- begin
- if AppletTerminated then Exit;
- GetCursorPos( Pt );
- Pt := Screen2Client( Pt );
- if (Applet.fHotCtl <> nil) and (fChildren.IndexOf( Applet.fHotCtl ) >= 0) then
- begin
- C := Applet.fHotCtl;
- if PtInRect( C.BoundsRect, Pt ) then Exit;
- Applet.fHotCtl := nil;
- C.fHot := FALSE;
- if not C.fWindowed then
- C.Invalidate;
- if Assigned( C.OnMouseLeave ) then
- C.OnMouseLeave( C );
- C.RefDec;
- end;
- end;
- {$ENDIF GRAPHCTL_HOTTRACK}
-
- procedure NotifyGraphCtlAboutNewParent(Prnt, Chld: PControl);
- begin
- if (Chld <> nil) and (Prnt <> nil) then
- begin
- Prnt.AttachProc( WndProc_ParentOfGraphicCtl );
- {if not Prnt.IsProcAttached( WndProc_ParentOfGraphicCtl ) then
- begin
- Prnt.fDynHandlers.Insert( 0, nil );
- Prnt.fDynHandlers.Insert( 0, @ WndProc_ParentOfGraphicCtl );
- end;}
- end;
- end;
-
- function _NewGraphCtl( AParent: PControl; ATabStop: Boolean ): PControl;
- begin
- {-}
- new( Result, Create );
- {+}{++}(*Result := PControl.CreateParented( AParent );*){--}
- Result.fDoInvalidate := Result.InvalidateNonWindowed;
- Result.fWindowed := FALSE;
- Result.fVisible := TRUE;
- Result.fCreateVisible := TRUE;
- Result.fIsControl := TRUE;
- Result.fMenu := CtlIdCount;
- Inc( CtlIdCount );
- Result.fBitBtnOptions := [ bboFixed ]; // to return Checked = fChecked w/o window handle
- Result.fIgnoreWndCaption := TRUE;
- Result.fNotifyChild := @ NotifyGraphCtlAboutNewParent;
- Result.fSizeRedraw := TRUE;
- Result.fTabstop := ATabStop;
- if ATabStop then
- Result.fLookTabKeys := [ tkTab, tkLeftRight, tkUpDown, tkPageUpPageDn ];
- if AParent <> nil then
- begin
- Result.Parent := AParent;
- Result.Border := AParent.Border;
- //if not AParent.IsProcAttached( WndProc_ParentOfGraphicCtl ) then
- begin
- AParent.AttachProc( WndProc_ParentOfGraphicCtl );
- //AParent.fDynHandlers.Insert( 0, nil );
- //AParent.fDynHandlers.Insert( 0, @ WndProc_ParentOfGraphicCtl );
- end;
- if ATabStop then
- begin
- Inc( AParent.ParentForm.fTabOrder );
- Result.fTabOrder := AParent.ParentForm.fTabOrder;
- end;
- if AParent.IsControl then
- AParent.ParentForm.AttachProc( WndProc_FormHavingGraphCtl );
- if AParent.fIsGroupBox then
- begin
- AParent.Style := AParent.Style and
- not BS_GROUPBOX; // otherwise the groupbox is flickering A LOT!
- AParent.Parent.AttachProc( WndProc_ParentOfGraphicCtl );
- end;
-
- Result.fFont := Result.fFont.Assign( AParent.fFont );
- if Result.fFont <> nil then
- begin
- Result.fFont.fParentGDITool := AParent.fFont;
- Result.fFont.fOnChange := Result.FontChanged;
- Result.FontChanged( Result.fFont );
- end;
- end;
- Result.fBoundsRect.Right := Result.fBoundsRect.Left + 64;
- Result.fBoundsRect.Bottom := Result.fBoundsRect.Top + 22;
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- if WinVer < wvXP then
- DoNotDrawGraphCtlsUsingXPStyles := TRUE;
- {$ENDIF}
- end;
-
- function NewGraphLabel( AParent: PControl; const ACaption: String ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewLabel( AParent, ACaption );
- {$ELSE}
- Result := _NewGraphCtl( AParent, FALSE );
- Result.fCommandActions := LabelActions;
- Result.fPaintProc := Result.GraphicLabelPaint;
- Result.Caption := ACaption;
- {$ENDIF}
- end;
-
- function NewWordWrapGraphLabel( AParent: PControl; const ACaption: KOLString ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewWordWrapLabel( AParent, ACaption );
- {$ELSE}
- Result := NewGraphLabel( AParent, ACaption );
- Result.fWordWrap := TRUE;
- {$ENDIF}
- end;
-
- function NewGraphPaintBox( AParent: PControl ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewPaintbox( AParent );
- {$ELSE}
- Result := NewGraphLabel( AParent, '' );
- {$ENDIF}
- end;
-
- procedure ClickGraphCheck(Sender: PObj);
- var Ctl: PControl;
- begin
- Ctl := Pointer( Sender );
- if not Ctl.Enabled then Exit;
- Ctl.Focused := TRUE;
- if Assigned( Ctl.OnEnter ) then
- Ctl.OnEnter( Ctl );
- Ctl.fChecked := not Ctl.fChecked;
- Ctl.Invalidate;
- if Assigned( Ctl.OnClick ) then
- Ctl.OnClick( Ctl );
- end;
-
- function NewGraphCheckBox( AParent: PControl; const ACaption: KOLString ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewCheckbox( AParent, ACaption );
- {$ELSE}
- Result := NewGraphButton( AParent, ACaption );
- Result.TextAlign := taLeft;
- Result.fCommandActions.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
- Result.fPaintProc := Result.GraphicCheckBoxPaint;
- Result.fGraphCtlMouseEvent := Result.GraphicCheckBoxMouse;
- Result.fControlClick := @ ClickGraphCheck;
- {$ENDIF}
- end;
-
- procedure ClickGraphRadio(Sender: PObj);
- var Ctl, C: PControl;
- i: Integer;
- begin
- Ctl := Pointer( Sender );
- if not Ctl.Enabled then Exit;
- Ctl.Focused := TRUE;
- Ctl.Checked := TRUE;
- if Ctl.Parent <> nil then
- for i := 0 to Ctl.Parent.ChildCount-1 do
- begin
- C := Ctl.Parent.Children[ i ];
- if (C <> Ctl) and (@ C.fControlClick = @ ClickGraphRadio) then
- C.Checked := FALSE;
- end;
- end;
-
- function NewGraphRadioBox( AParent: PControl; const ACaption: KOLString ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewRadiobox( AParent, ACaption );
- if (@ ClickGraphRadio) <> nil then;
- {$ELSE}
- Result := NewGraphButton( AParent, ACaption );
- Result.TextAlign := taLeft;
- Result.fCommandActions.aAutoSzX := GetSystemMetrics( SM_CXMENUCHECK ) + 4;
- Result.fPaintProc := Result.GraphicRadioBoxPaint;
- Result.fControlClick := @ ClickGraphRadio;
- if AParent <> nil then
- begin
- AParent.fRadioLast := Result.fMenu;
- if AParent.fRadio1st = 0 then
- begin
- AParent.fRadio1st := Result.fMenu;
- Result.SetRadioChecked;
- end;
- end;
- {$ENDIF}
- end;
-
- function NewGraphButton( AParent: PControl; const ACaption: KOLString ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewButton( AParent, ACaption );
- {$ELSE}
- Result := _NewGraphCtl( AParent, TRUE );
- Result.fCommandActions := ButtonActions;
- Result.fPaintProc := Result.GraphicButtonPaint;
- Result.Caption := ACaption;
- Result.TextAlign := taCenter;
- Result.VerticalAlign := vaCenter;
- Result.fGraphCtlMouseEvent := Result.GraphicButtonMouse;
- Result.fSetFocus := Result.GraphButtonSetFocus;
- Result.fKeyboardProcess := Result.GraphButtonKeyboardProcess;
- {$ENDIF}
- end;
-
- function NewGraphEditbox( AParent: PControl; Options: TEditOptions ): PControl;
- begin
- {$IFDEF INPACKAGE}
- Result := NewEditbox( AParent, Options );
- {$ELSE}
- Result := _NewGraphCtl( AParent, TRUE );
- Result.fCommandActions := EditActions;
- Result.fPaintProc := Result.GraphicEditPaint;
- Result.fEditOptions := Options;
- Result.VerticalAlign := vaCenter;
- Result.fColor := clWindow;
- Result.fGraphCtlMouseEvent := Result.GraphicEditMouse;
- Result.fSetFocus := Result.GraphEditBoxSetFocus;
- Result.fLookTabKeys := [ tkTab, tkUpDown, tkPageUpPageDn ];
- Result.fLeave := Result.LeaveGraphEdit;
- {$ENDIF}
- end;
-
- { TGraphicControl }
-
- function TControl.DoGraphCtlPrepaint: TRect;
- begin
- Result := ClientRect;
- if not Assigned( OnPrepaint ) and not Transparent then
- begin
- if Assigned( fBrush ) then
- Canvas.Brush.Assign( fBrush )
- else
- Canvas.Brush.Color := Color;
- Canvas.FillRect( Result );
- end;
- end;
-
- procedure TControl.GraphicLabelPaint(DC: HDC);
- var R: TRect;
- begin
- R := DoGraphCtlPrepaint;
- if Text <> '' then
- DrawFormattedText( @ Self, DC, R, 0 );
- //SaveImg( Canvas, R, 'bm09.bmp' );
- //sv1 := FALSE;
- end;
-
- procedure TControl.GraphicCheckBoxPaint(DC: HDC);
- var R, R1: TRect;
- Flag: DWORD;
- W, H: Integer;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Theme: THandle;
- {$ENDIF}
- begin
- R := DoGraphCtlPrepaint;
- {
- R := ClientRect;
- if not Assigned( OnPrepaint ) and not Transparent then
- begin
- if Assigned( fBrush ) then
- Canvas.Brush.Assign( fBrush )
- else
- Canvas.Brush.Color := Color;
- Canvas.FillRect( R );
- end;
- }
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- OpenThemeDataProc;
- Theme := 0;
- if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
- Theme := fOpenThemeDataProc( 0, 'Button' );
- if Theme <> 0 then
- begin
-
- W := GetSystemMetrics( SM_CXMENUCHECK );
- H := GetSystemMetrics( SM_CYMENUCHECK );
-
- R1 := R;
- R1.Right := R1.Left + W;
- if fWordWrap then
- R1.Top := R1.Top + Border
- else
- R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
- R1.Bottom := R1.Top + H;
-
- Flag := 1; {CBS_UNCHECKEDNORMAL}
- if not Enabled then
- Flag := 4 {CBS_UNCHECKEDDISABLED}
- else
- if fHot then
- Flag := 2; {CBS_UNCHECKEDHOT}
- if fChecked then
- Inc( Flag, 4 );
- fDrawThemeBackground( Theme, DC, 3 {BP_CHECKBOX}, Flag, @R1, @R );
-
- R.Left := R1.Left + W + Border;
-
- if fCaption <> '' then
- begin
- DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
- if fWordWrap then
- begin
- DrawFormattedText( @ Self, DC, R, 0 );
- GraphCtlDrawFocusRect( DC, R );
- end
- else
- begin
- GraphCtlDrawFocusRect( DC, R );
- DrawFormattedTextXP( Theme, @ Self, DC, R, 3 {BP_CHECKBOX}, Flag, 0, 0 );
- end;
- end;
-
- fCloseThemeData( Theme );
- end
- else
- {$ENDIF}
- begin
-
- W := GetSystemMetrics( SM_CXMENUCHECK );
- H := GetSystemMetrics( SM_CYMENUCHECK );
-
- R1 := R;
- R1.Right := R1.Left + W;
- if fWordWrap then
- R1.Top := R1.Top + Border
- else
- R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
- R1.Bottom := R1.Top + H;
- //if not Transparent then
- begin
- Flag := 0;
- if fChecked then
- Flag := DFCS_CHECKED;
- DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONCHECK or
- $800 {DFCS_TRANSPARENT} or Flag );
- end;
-
- R.Left := R1.Left + W + Border;
- DrawFormattedText( @ Self, DC, R, 0 );
- GraphCtlDrawFocusRect( DC, R );
- end;
- end;
-
- procedure TControl.GraphicCheckBoxMouse(var Msg: TMsg);
- begin
- if (Msg.message = WM_LBUTTONDOWN) or (Msg.message = WM_LBUTTONDBLCLK) then
- ClickGraphCheck( @ Self );
- end;
-
- procedure TControl.GraphicRadioBoxPaint(DC: HDC);
- var R, R1: TRect;
- Flag: DWORD;
- W, H: Integer;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Theme: THandle;
- {$ENDIF}
- begin
- R := DoGraphCtlPrepaint;
- {R := ClientRect;
- if not Assigned( OnPrepaint ) and not Transparent then
- Canvas.FillRect( R );}
- {$IFDEF GRAPHCTL_XPSTYLES}
- OpenThemeDataProc;
- Theme := 0;
- if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
- Theme := fOpenThemeDataProc( 0, 'Button' );
- if Theme <> 0 then
- begin
-
- W := GetSystemMetrics( SM_CXMENUCHECK );
- H := GetSystemMetrics( SM_CYMENUCHECK );
-
- R1 := R;
- R1.Right := R1.Left + W;
- if fWordWrap then
- R1.Top := R1.Top + Border
- else
- R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
- R1.Bottom := R1.Top + H;
-
- Flag := 1; {CBS_UNCHECKEDNORMAL}
- if not Enabled then
- Flag := 4 {CBS_UNCHECKEDDISABLED}
- else
- if fHot then
- Flag := 2; {CBS_UNCHECKEDHOT}
- if fChecked then
- Inc( Flag, 4 );
- fDrawThemeBackground( Theme, DC, 2 {BP_RADIOBOX}, Flag, @R1, @R );
-
- R.Left := R1.Left + W + Border;
-
- if fCaption <> '' then
- begin
- DrawFormattedText( @ Self, DC, R, DT_CALCRECT );
- if fWordWrap then
- begin
- DrawFormattedText( @ Self, DC, R, 0 );
- GraphCtlDrawFocusRect( DC, R );
- end
- else
- begin
- GraphCtlDrawFocusRect( DC, R );
- DrawFormattedTextXP( Theme, @ Self, DC, R, 2 {BP_RADIOBOX}, Flag, 0, 0 );
- end;
- end;
- fCloseThemeData( Theme );
- end
- else
- {$ENDIF}
- begin
- W := GetSystemMetrics( SM_CXMENUCHECK );
- H := GetSystemMetrics( SM_CYMENUCHECK );
- R1 := R;
- R1.Right := R1.Left + W;
- if fWordWrap then
- R1.Top := R1.Top + Border
- else
- R1.Top := R1.Top + (R1.Bottom - R1.Top - H) div 2;
- R1.Bottom := R1.Top + H;
- //if not Transparent then
- begin
- Flag := 0;
- if fChecked then
- Flag := DFCS_CHECKED;
- DrawFrameControl( DC, R1, DFC_BUTTON, DFCS_BUTTONRADIO
- or $800 {DFCS_TRANSPARENT} {or DFCS_ADJUSTRECT} or Flag );
- end;
- R.Left := R1.Right + 2;
- DrawFormattedText( @ Self, DC, R, 0 );
- GraphCtlDrawFocusRect( DC, R );
- end;
- end;
-
- procedure TControl.GraphicButtonPaint(DC: HDC);
- var R: TRect;
- Flag: DWORD;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Flag1: DWORD;
- Theme: THandle;
- {$ENDIF}
- II: TIconInfo;
- BI: TagBitmap;
- Y: Integer;
- R1: TRect;
- begin
- R := DoGraphCtlPrepaint;
- {$IFDEF GRAPHCTL_XPSTYLES}
- OpenThemeDataProc;
- Theme := 0;
- if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
- Theme := fOpenThemeDataProc( 0, 'Button' );
- if Theme <> 0 then
- begin
- Flag := 1; {PBS_UNCHECKEDNORMAL}
- if not Enabled then
- Flag := 4 {PBS_UNCHECKEDDISABLED}
- else
- if fPushed then
- Flag := 3 {PBS_UNCHECKEDPRESSED}
- else
- if fHot then
- Flag := 2; {PBS_UNCHECKEDHOT}
- if fChecked then
- Inc( Flag, 4 );
-
- fDrawThemeBackground( Theme, DC, 1 {BP_PUSHBUTTON}, Flag, @R, @R );
-
- fGetThemeBackgroundContentRect( Theme, DC, 1 {BS_PUSHBUTTON}, Flag, @R, @R1 );
- GraphCtlDrawFocusRect( DC, R1 );
-
- if (fButtonIcon <> 0) and GetIconInfo( fButtonIcon, II ) then
- begin
- if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then
- begin
- CASE fVerticalAlign OF
- vaTop:
- Y := R.Top + Border;
- vaBottom:
- Y := R.Bottom - Border - BI.bmHeight;
- else //vaCenter:
- Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
- END;
- DrawIcon( DC, R.Left + Border, Y, fButtonIcon );
- Inc( R1.Left, BI.bmWidth + Border * 2 );
- end;
- DeleteObject( II.hbmColor );
- if II.hbmMask <> 0 then
- DeleteObject( II.hbmMask );
- end;
-
- if fCaption <> '' then
- begin
- Flag1 := DT_SINGLELINE;
- if WordWrap then
- Flag1 := DT_WORDBREAK;
- DrawFormattedText( @ Self, DC, R1, DT_CALCRECT );
- DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {BP_PUSHBUTTON}, Flag,
- Flag1, 0 );
- end;
- fCloseThemeData( Theme );
- end
- else
- {$ENDIF}
- begin
- Flag := 0;
- if fChecked then
- Flag := DFCS_CHECKED
- else
- if fPushed then
- Flag := DFCS_PUSHED;
- if fFlat then
- Flag := Flag or DFCS_FLAT;
- DrawFrameControl( DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or
- $800 {DFCS_TRANSPARENT} or DFCS_ADJUSTRECT or Flag );
- //{$IFNDEF GRAPHCTL_XPSTYLES}
- R1 := R;
- //{$ENDIF}
-
- if (fButtonIcon <> 0) and GetIconInfo( fButtonIcon, II ) then
- begin
- if GetObject( II.hbmColor, Sizeof( BI ), @ BI ) <> 0 then
- begin
- CASE fVerticalAlign OF
- vaTop:
- Y := R.Top + Border;
- vaBottom:
- Y := R.Bottom - Border - BI.bmHeight;
- else //vaCenter:
- Y := R.Top + (R.Bottom - R.Top - BI.bmHeight) div 2;
- END;
- DrawIcon( DC, R.Left + Border, Y, fButtonIcon );
- Inc( R1.Left, BI.bmWidth + Border * 2 );
- end;
- DeleteObject( II.hbmColor );
- if II.hbmMask <> 0 then
- DeleteObject( II.hbmMask );
- end;
-
- DrawFormattedText( @ Self, DC, R1, 0 );
- GraphCtlDrawFocusRect( DC, R );
- end;
- end;
-
- procedure TControl.GraphicButtonMouse(var Msg: TMsg);
- var Pt: TPoint;
- begin
- CASE Msg.message OF
- WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
- begin
- GraphButtonSetFocus;
- RefInc;
- SetCapture( Parent.Handle );
- Parent.fPushedBtn := @ Self;
- fPushed := TRUE;
- Invalidate;
- end;
- WM_LBUTTONUP:
- begin
- ReleaseCapture;
- Invalidate;
- if fPushed then
- begin
- Pt.X := SmallInt( LoWord( Msg.lParam ) );
- Pt.Y := SmallInt( HiWord( Msg.lParam ) );
- if PtInRect( ClientRect, Pt ) then
- DoClick;
- fPushed := FALSE;
- Parent.fPushedBtn := nil;
- RefDec;
- end;
- end;
- END;
- end;
-
- procedure TControl.GraphButtonSetFocus;
- var PF: PControl;
- CC: PControl;
- W: HWnd;
- begin
- if not fTabStop then Exit;
- PF := ParentForm;
- if (PF.fCurrentControl <> nil) and (PF.fCurrentControl <> @ Self) and
- (PF.fCurrentControl <> Parent) then
- begin
- CC := PF.fCurrentControl;
- CC.RefInc;
- Parent.Focused := TRUE;
- if Assigned( CC.fLeave ) then
- CC.fLeave( PF.fCurrentControl )
- else
- Windows.SetFocus( 0 );
- CC.RefDec;
- end
- else
- begin
- W := GetFocus;
- if (W <> Parent.fHandle) and (W <> 0) then
- begin
- Windows.SetFocus( 0 );
- Parent.Focused := TRUE;
- end;
- end;
- if Parent.fHandle <> 0 then
- begin
- fFocused := TRUE;
- Parent.Postmsg( CM_FOCUSGRAPHCTL, Integer( @ Self ), 0 );
- RefInc;
- end;
- if Assigned( fOnEnter ) then
- fOnEnter( @ Self );
- end;
-
- procedure TControl.LeaveGraphButton( Sender: PObj );
- begin
- fFocused := FALSE;
- if Parent.fCurrentControl = @ Self then
- Parent.fCurrentControl := nil;
- if ParentForm.fCurrentControl = @ Self then
- ParentForm.fCurrentControl := nil;
- Invalidate;
- if Assigned( fOnLeave ) then
- fOnLeave( @ Self );
- end;
-
- function TControl.GraphButtonKeyboardProcess(var Msg: TMsg;
- var Rslt: Integer): Boolean;
- var SpacePressed: Boolean;
- begin
- Result := FALSE;
- SpacePressed := Msg.wParam = Word( ' ' );
- {$IFDEF ALL_BUTTONS_RESPOND_TO_ENTER}
- SpacePressed := SpacePressed or (Msg.wParam = 13);
- {$ENDIF}
- if not SpacePressed then Exit;
- if (Msg.message = WM_KEYDOWN) or (Msg.message = WM_SYSKEYDOWN) then
- begin
- Parent.fPushedBtn := @ Self;
- fPushed := TRUE;
- Invalidate;
- Result := TRUE; /////
- end
- else
- if (Msg.message = WM_KEYUP) or (Msg.message = WM_SYSKEYUP) then
- begin
- fPushed := FALSE;
- Parent.fPushedBtn := nil;
- Invalidate;
- Result := TRUE; /////
- end
- else
- if (Msg.message = WM_CHAR) or (Msg.message = WM_SYSCHAR) then
- begin
- DoClick;
- Result := TRUE;
- end;
- end;
-
- procedure TControl.GraphicEditPaint(DC: HDC);
- var R: TRect;
- {$IFDEF GRAPHCTL_XPSTYLES}
- R1: TRect;
- Flag, Flag1: DWORD;
- Theme: THandle;
- {$ENDIF}
- begin
- R := ClientRect;
- {$IFDEF GRAPHCTL_XPSTYLES}
- OpenThemeDataProc;
- Theme := 0;
- if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
- Theme := fOpenThemeDataProc( 0, 'Edit' );
- if Theme <> 0 then
- begin
- Flag := 1; {ETS_NORMAL}
- if not Enabled then
- Flag := 4 {ETS_DISABLED}
- else
- if eoReadonly in fEditOptions then
- Flag := 6 {ETS_READONLY}
- else
- if fFocused then
- Flag := 5 {ETS_FOCUSED}
- else
- if fHot then
- Flag := 2; {ETS_HOT}
-
- fDrawThemeBackground( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R );
-
- Inc( R.Left, 2 );
- Dec( R.Right, 2 );
- fGetThemeBackgroundContentRect( Theme, DC, 1 {EP_EDITTEXT}, Flag, @R, @R1 );
-
- if fCaption <> '' then
- begin
- Flag1 := DT_SINGLELINE;
- if eoMultiline in fEditOptions then
- Flag1 := DT_WORDBREAK;
- CASE fTextAlign OF
- taCenter: Flag1 := Flag1 or DT_CENTER;
- taRight: Flag1 := Flag1 or DT_RIGHT;
- //else Flag1 := Flag1 or DT_LEFT;
- END;
- CASE fVerticalAlign OF
- vaCenter: Flag1 := Flag1 or DT_VCENTER;
- vaBottom: Flag1 := Flag1 or DT_BOTTOM;
- //else Flag1 := Flag1 or DT_TOP;
- END;
- DrawFormattedTextXP( Theme, @ Self, DC, R1, 1 {EP_EDITTEXT}, Flag,
- Flag1, 0 );
- end;
- fCloseThemeData( Theme );
- end
- else
- {$ENDIF}
- begin
- if not Assigned( OnPrepaint ) and not Transparent then
- begin
- Canvas.Brush.Color := fColor;
- Canvas.FillRect( R );
- end;
-
- DrawEdge( DC, R, BDR_SUNKENINNER or BDR_SUNKENOUTER, BF_ADJUST or BF_RECT );
-
- DrawFormattedText( @ Self, DC, R, DT_EDITCONTROL );
- end;
- end;
-
- procedure TControl.GraphicEditMouse(var Msg: TMsg);
- var E: PControl;
- Pt: TPoint;
- begin
- CASE Msg.message OF
- WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
- if not ( eoReadOnly in fEditOptions ) then
- begin
- E := EditGraphEdit;
- Pt.X := Smallint( LoWord( Msg.lParam ) ) - Left;
- Pt.Y := Smallint( HiWord( Msg.lParam ) ) - Top;
- PostMessage( E.Handle, Msg.message, Msg.wParam,
- Pt.Y shl 16 or Pt.X and $FFFF );
- end;
- END;
- end;
-
- function TControl.EditGraphEdit: PControl;
- var E: PControl;
- begin
- E := NewEditBox( Parent, fEditOptions )
- .SetPosition( Left, Top )
- .SetSize( Width, Height )
- .SetAlign( Align );
- E.fTabOrder := fTabOrder;
- E.Text := Text;
- E.OnChange := ChangeGraphEdit;
- E.Color := Color;
- E.fCursor := fCursor;
- E.CreateWindow;
- E.OnLeave := LeaveGraphEdit;
- E.fLeave := LeaveGraphEdit;
- E.Focused := TRUE;
- E.OnChar := OnChar;
- E.OnKeyDown := OnKeyDown;
- E.OnKeyUp := OnKeyUp;
- E.OnDestroy := DestroyGraphEdit;
- //E.Font.Assign( Font );
- Result := E;
- Visible := FALSE;
- fEditCtl := E;
- if Assigned( fOnEnter ) then
- fOnEnter( @ Self );
- end;
-
- procedure TControl.LeaveGraphEdit(Sender: PObj);
- begin
- if PControl( Sender ).fWindowed and Assigned( fEditCtl ) then
- begin
- Text := PControl( Sender ).Text;
- fEditCtl := nil;
- Visible := TRUE;
- ParentForm.fCurrentControl := @ Self;
- Parent.fCurrentControl := @ Self;
- Parent.Postmsg( CM_QUIT, DWORD( Sender ), 0 );
- end
- else
- if Assigned( fEditCtl ) then
- begin
- fEditCtl.fLeave( fEditCtl );
- end;
- end;
-
- procedure TControl.ChangeGraphEdit(Sender: PObj);
- begin
- Text := PControl( Sender ).Text;
- end;
-
- procedure TControl.GraphEditboxSetFocus;
- begin
- EditGraphEdit;
- end;
-
- procedure TControl.DestroyGraphEdit(Sender: PObj);
- begin
- fEditCtl := nil;
- end;
-
- procedure TControl.GraphCtlDrawFocusRect(DC: HDC; const R: TRect);
- var rgn: HRgn;
- begin
- if fFocused and (GetActiveWindow = ParentForm.Handle) then
- begin
- BeginPath( DC );
- Canvas.FrameRect( R );
- EndPath( DC );
- Canvas.FrameRect( R );
- DrawFocusRect( DC, R );
- rgn := PathToRegion( DC );
- ExtSelectClipRgn( DC, rgn, RGN_DIFF );
- DeleteObject( rgn );
- end;
- end;
-
- procedure TControl.GroupBoxPaint(DC: HDC);
- var bk_erased: Boolean;
-
- procedure DoEraseBkgnd;
- var R: TRect;
- begin
- bk_erased := TRUE;
- if Assigned( OnEraseBkgnd ) then
- OnEraseBkgnd( @ Self, DC )
- else
- begin
- R := BoundsRect;
- OffsetRect( R, -R.Left, -R.Top );
- SetBkMode( DC, OPAQUE );
- SetBkColor( DC, Color2RGB( fColor ) );
- SetBrushOrgEx( DC, 0, 0, nil );
- Windows.FillRect( DC, R, Global_GetCtlBrushHandle( @ Self ) );
- end;
- end;
-
- var R, R1, R0: TRect;
- rgn, rgn2, rgntxt, rgnsav, rgnsavall: HRgn;
- i: Integer;
- C: PControl;
- {$IFDEF GRAPHCTL_XPSTYLES}
- Theme: THandle;
- Flag: DWORD;
- {$ENDIF}
- begin
- if not fErasingBkgnd then
- Exit;
- R := ClientRect;
- Dec( R.Top, 14 { Self_.fClientTop div 2 } );
- Dec( R.Left, fClientLeft );
- Inc( R.Right, fClientRight );
- Inc( R.Bottom, fClientBottom );
-
- rgnsavall := CreateRectRgn( 0, 0, 0, 0 );
- GetClipRgn( DC, rgnsavall );
-
- TRY
-
- for i := 0 to ChildCount-1 do
- begin
- C := Children[ i ];
- if not C.fWindowed and C.fVisible then
- begin
- rgn := CreateRectRgnIndirect( C.BoundsRect );
- ExtSelectClipRgn( DC, rgn, RGN_DIFF );
- DeleteObject( rgn );
- end;
- end;
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- OpenThemeDataProc;
- Theme := 0;
- if Assigned( fOpenThemeDataProc ) and not DoNotDrawGraphCtlsUsingXPStyles then
- Theme := fOpenThemeDataProc( 0, 'Button' );
- if Theme <> 0 then
- begin
- DoEraseBkgnd;
-
- Flag := 1; {GBS_NORMAL}
- if not Enabled then
- Flag := 2; {GBS_DISABLED}
- R1 := R;
-
- rgnsav := 0;
- if fCaption <> '' then
- begin
- R1.Top := 0;
- Inc( R1.Left, 8 );
- Dec( R1.Right, 8 );
- BeginPath( DC );
- DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
- EndPath( DC );
- rgntxt := PathToRegion( DC );
- if rgntxt = 0 then
- begin
- R1.Right := R1.Left + Canvas.TextWidth( fCaption );
- R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
- rgntxt := CreateRectRgnIndirect( R1 );
- end;
- DrawFormattedTextXP( Theme, @ Self, DC, R1, 4 {BP_GROUPBOX}, Flag, 0, 0 );
- GetRgnBox( rgntxt, R0 );
- Dec( R0.Left, 3 );
- Inc( R0.Right, 3 );
- DeleteObject( rgntxt );
- rgn := CreateRectRgnIndirect( R0 );
- end
- else
- begin
- rgn := 0;
- end;
- if rgn <> 0 then
- begin
- rgnsav := CreateRectRgn( 0, 0, 0, 0 );
- GetClipRgn( DC, rgnsav );
- ExtSelectClipRgn( DC, rgn, RGN_DIFF );
- DeleteObject( rgn );
- end;
- fDrawThemeBackground( Theme, DC, 4 {BP_GROUPBOX}, Flag, @R, @R );
- if rgnsav <> 0 then
- begin
- SelectClipRgn( DC, rgnsav );
- DeleteObject( rgnsav );
- end;
-
- fCloseThemeData( Theme );
- end
- else
- {$ENDIF}
- begin
- bk_erased := FALSE;
-
- R1 := R;
- R1.Top := 0;
- R1.Bottom := ClientRect.Top;
- Inc( R1.Left, 16 );
- Dec( R1.Right, 16 );
- fVerticalAlign := vaCenter;
- BeginPath( DC );
- Canvas.TextOut( R1.Left, R1.Top, fCaption );
- EndPath( DC );
- Canvas.TextOut( R1.Left, R1.Top, fCaption );
- rgntxt := PathToRegion( DC );
- if rgntxt = 0 then // òàêîå - â ñëó÷àå øðèôòà ïî óìîë÷àíè³!
- begin
- R1.Right := R1.Left + Canvas.TextWidth( fCaption );
- R1.Bottom := R1.Top + Canvas.TextHeight( fCaption );
- rgntxt := CreateRectRgnIndirect( R1 );
- end;
-
- GetRgnBox( rgntxt, R0 );
- rgn2 := CreateRectRgnIndirect( R0 );
-
- rgnsav := CreateRectRgn( 0, 0, 0, 0 );
- GetClipRgn( DC, rgnsav );
- ExtSelectClipRgn( DC, rgn2, RGN_DIFF );
- DeleteObject( rgn2 );
-
- BeginPath( DC );
- DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
- EndPath( DC );
- rgn := PathToRegion( DC );
- if rgn = 0 then DoEraseBkgnd;
- DrawEdge( DC, R, BDR_RAISEDINNER or BDR_SUNKENOUTER, BF_RECT );
-
- SelectClipRgn( DC, rgnsav );
- DeleteObject( rgnsav );
-
- if rgn <> 0 then
- begin
- ExtSelectClipRgn( DC, rgn, RGN_DIFF );
- DeleteObject( rgn );
- end;
- ExtSelectClipRgn( DC, rgntxt, RGN_DIFF );
- DeleteObject( rgntxt );
-
- if not bk_erased then DoEraseBkgnd;
- end;
-
- FINALLY
- SelectClipRgn( DC, rgnsavall );
- DeleteObject( rgnsavall );
- END;
- end;
- {$ENDIF USE_GRAPHCTLS}
-
- function TControl.MakeWordWrap: PControl;
- begin
- fWordWrap := TRUE;
- Style := (fStyle and not SS_LEFTNOWORDWRAP) or BS_MULTILINE;
- Result := @ Self;
- end;
-
- function ParentAnchorChildren( Sender: PControl; var Msg: TMsg;
- var Rslt: Integer ): Boolean;
- var NewW, NewH: Integer;
- dW, dH: Integer;
- i: Integer;
- C: PControl;
- {$IFNDEF ANCHORS_WM_SIZE}
- CR: TRect;
- {$ENDIF}
- begin
- Result := FALSE;
- if (Msg.message = {$IFDEF ANCHORS_WM_SIZE} WM_SIZE {$ELSE} WM_WINDOWPOSCHANGED {$ENDIF} )
- {$ifndef wince} and not IsIconic(Sender.Handle) {$endif} then
- begin
- {$IFDEF ANCHORS_WM_SIZE}
- NewW := LoWord( Msg.lParam ) - Sender.fClientLeft - Sender.fClientRight;
- NewH := HiWord( Msg.lParam ) - Sender.fClientTop - Sender.fClientBottom;
- {$ELSE}
- CR := Sender.ClientRect;
- NewW := CR.Right;
- NewH := CR.Bottom;
- {$ENDIF}
- dW := NewW - Sender.fOldWidth;
- dH := NewH - Sender.fOldHeight;
- for i := 0 to Sender.ChildCount - 1 do
- begin
- C := Sender.Children[ i ];
-
- if dW <> 0 then
- begin
- if C.AnchorRight and C.AnchorLeft then
- C.Width := C.Width + dW
- else if C.AnchorRight then
- C.Left := C.Left + dW;
- end;
- if dH <> 0 then
- begin
- if C.AnchorBottom and C.AnchorTop then
- C.Height := C.Height + dH
- else if C.AnchorBottom then
- C.Top := C.Top + dH;
- end;
-
- end;
- Sender.fOldWidth := NewW;
- Sender.fOldHeight := NewH;
- end;
- end;
-
- function TControl.Anchor(aLeft, aTop, aRight, aBottom: Boolean): PControl;
- begin
- if (not aLeft) and aRight then
- SetAnchorLeft( FALSE )
- else
- SetAnchorLeft( aLeft );
-
- if (not aTop) and aBottom then
- SetAnchorTop( FALSE )
- else
- SetAnchorTop( aTop );
-
- SetAnchorRight( aRight );
- SetAnchorBottom( aBottom );
-
- Result := @ Self;
- end;
-
- procedure TControl.SetAnchorLeft(const Value: Boolean);
- begin
- fAnchorLeft := Value;
- if Parent <> nil then
- begin
- fParent.AttachProc( ParentAnchorChildren );
- Parent.fOldWidth := Parent.ClientWidth;
- end;
- end;
-
- procedure TControl.SetAnchorTop(const Value: Boolean);
- begin
- fAnchorTop := Value;
- if Parent <> nil then
- begin
- fParent.AttachProc( ParentAnchorChildren );
- fParent.fOldHeight := Parent.ClientHeight;
- end;
- end;
-
- procedure TControl.SetAnchorBottom(Value: Boolean);
- begin
- fAnchorBottom := Value;
- if Parent <> nil then
- begin
- fParent.AttachProc( ParentAnchorChildren );
- fParent.fOldHeight := Parent.ClientHeight;
- end;
- end;
-
- procedure TControl.SetAnchorRight(Value: Boolean);
- begin
- fAnchorRight := Value;
- if Parent <> nil then
- begin
- Parent.AttachProc( ParentAnchorChildren );
- Parent.fOldWidth := Parent.ClientWidth;
- end;
- end;
-
- function TControl.GetLBTopIndex: Integer;
- begin
- Result := Perform(LB_GETTOPINDEX,0,0);
- end;
-
- function TControl.LBItemAtPos(X, Y: Integer): Integer;
- var
- R: TRect;
- P: TPoint;
- i: Integer;
- begin
- P := MakePoint(X,Y);
- for i := LBTopIndex to Count -1 do begin
- Perform(LB_GETITEMRECT, i , Integer(@R));
- if PointInRect(P,R) then begin
- Result := i;
- Exit;
- end;
- end;
- Result := -1;
- end;
-
- procedure TControl.SetLBTopIndex(const Value: Integer);
- begin
- Perform(LB_SETTOPINDEX,Value,0);
- end;
-
- //--------
-
- procedure ScrollToChild(C, SB: PControl);
-
- function DoScroll(msg, bar, d1, d2, client: integer): boolean;
- var
- i: integer;
- begin
- i:=GetScrollPos(SB.Handle, bar);
- if d1 < SB.Border then
- Dec(i, SB.Border - d1)
- else
- if d2 > client - SB.Border then
- Inc(i, d2 - client + SB.Border)
- else begin
- Result:=False;
- exit;
- end;
- SetScrollPos(SB.Handle, bar, i, True);
- Result:=True;
- end;
-
- var
- R: TRect;
- begin
- if C = nil then exit;
- R:=C.BoundsRect;
- R.TopLeft:=SB.Screen2Client(C.Parent.Client2Screen(R.TopLeft));
- R.BottomRight:=SB.Screen2Client(C.Parent.Client2Screen(R.BottomRight));
- if DoScroll(WM_VSCROLL, SB_VERT, R.Top, R.Bottom, SB.ClientHeight) or
- DoScroll(WM_HSCROLL, SB_HORZ, R.Left, R.Right, SB.ClientWidth)
- then
- ScrollChildren(SB);
- end;
-
- function WndProcScrollable( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
-
- procedure ProcessScroll;
- begin
- NotifyScrollBox(Sender, nil);
- ScrollToChild(Sender.ParentForm.ActiveControl, Sender);
- end;
-
- begin
- Result:=False;
- case Msg.message of
- WM_SIZE:
- PostMessage(Sender.fHandle, CM_SHOW, 0, 0);
- WM_SHOWWINDOW:
- if WordBool(Msg.wParam) then
- PostMessage(Sender.fHandle, CM_SHOW, 0, 0);
- CM_SHOW:
- begin
- ProcessScroll;
- Result:=True;
- end;
- end;
- end;
-
- function WndProcScrollToChild( Sender: PControl; var Msg: TMsg; var Rslt: Integer ): Boolean;
- var
- P: PControl;
- begin
- Result:=False;
- if Msg.message = WM_SETFOCUS then begin
- P:=Sender.Parent;
- while (P <> nil) and not Assigned(P.fScrollChildren) do
- P:=P.Parent;
- if P <> nil then
- ScrollToChild(Sender, P);
- end;
- end;
-
- procedure NotifyScroller( Self_, Child: PControl );
- begin
- if Assigned(Child) then begin
- Child.AttachProc(@WndProcScrollToChild);
- if not Assigned(Child.fNotifyChild) then
- Child.fNotifyChild:=@NotifyScroller;
- end;
- end;
-
- procedure TControl.MakeScrollable;
-
- procedure AttachProcToChildren(P: PControl);
- var
- i: integer;
- C: PControl;
- begin
- for i:=0 to P.ChildCount - 1 do begin
- C:=P.Children[i];
- NotifyScroller(P, C);
- AttachProcToChildren(C);
- end;
- end;
-
- begin
- if not IsProcAttached( WndProcScrollBox ) then begin
- fDynHandlers.Insert(0, nil);
- fDynHandlers.Insert(0, @WndProcScrollBox);
- end;
- AttachProc( WndProcScrollable );
- fScrollChildren := ScrollChildren;
- FScrollLineDist[ 0 ] := 16;
- FScrollLineDist[ 1 ] := 16;
- fNotifyChild:=@NotifyScroller;
- AttachProcToChildren(@Self);
- end;
- {$ENDIF WIN_GDI}
-
- procedure TControl.DisableAlign;
- begin
- Include(fAligning, oaAligning);
- end;
-
- procedure TControl.EnableAlign;
- begin
- fAligning:=[];
- Global_Align(@Self);
- end;
-
- {$IFNDEF PAS_VERSION}
- // {$DEFINE ASM_VERSION}
- // {$DEFINE ASM_UNICODE}
- {$I KOL_ASM.inc} {$ENDIF ASM_VERSION}
- {$IFDEF LIN}
- {$DEFINE implementation} {$I KOL_Linux.inc} {$UNDEF implementation}
- {$ENDIF LIN}
-
- { -- }
- {$IFDEF USE_CUSTOMEXTENSIONS}
- {$I CUSTOM_CODE_EXTENSION.inc} // See comments in TControl
- {$ENDIF USE_CUSTOMEXTENSIONS}
-
- //[initialization]
-
- {$IFNDEF NOT_UNLOAD_RICHEDITLIB}
- {$IFDEF UNLOAD_RICHEDITLIB}
- {$DEFINE INIT_FINIT}
- {$ENDIF}
- {$ENDIF}
-
- {$IFDEF USE_NAMES}
- {$DEFINE INIT_FINIT}
- {$ENDIF}
-
- {$IFDEF GRAPHCTL_XPSTYLES}
- {$DEFINE INIT_FINIT}
- {$ENDIF}
-
- {$IFDEF KOL_MMX}
- {$DEFINE INIT_FINIT}
- {$ENDIF}
-
- {$IFDEF INIT_FINIT}
-
- initialization
- {$IFDEF GRAPHCTL_XPSTYLES}
- CheckThemes;
- if AppTheming then
- InitThemes;
- {$ENDIF}
-
- //[finalization]
- finalization
- {$IFDEF GRAPHCTL_XPSTYLES}
- if AppTheming then
- DeinitThemes;
- {$ENDIF}
-
- {$IFNDEF NOT_UNLOAD_RICHEDITLIB}
- {$IFDEF UNLOAD_RICHEDITLIB}
- if FRichEditModule <> 0 then
- FreeLibrary( FRichEditModule );
- {$ENDIF UNLOAD_RICHEDITLIB}
- {$ENDIF}
- {$ENDIF INIT_FINIT}
-
- //[END OF KOL.pas]
- end.
|