tag:blogger.com,1999:blog-76917230693735779072020-11-13T12:34:56.128+02:00The Spirit of DelphiProgramming tips, tricks and toolsDorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.comBlogger136125tag:blogger.com,1999:blog-7691723069373577907.post-38027384549731259092013-01-18T20:06:00.002+02:002013-01-18T20:07:06.687+02:00Generic array sliceNot sure if anyone created(in delphi) something similar yet, which should indicate that it's usage is very limited, but here it goes...<br /><br />Ever played with huge arrays and you always have to copy chunks into smaller arrays which then you want to feed to some algorithm(or pass a bunch of indexes)? if yes, then you should know by now that a "slice of TYPE" functionality kinda', shoulda' be available by now in Delphi's compiler... anyhu' with the introduction of generics, we got the options to shoot ourselves in the foot or come up with good ideas, depending on your POV.<br /><br />So, what is an array slice? Well, <a href="http://en.wikipedia.org/wiki/Array_slicing">wiki</a> says that it grabs a <i>slice</i> of an array and puts it into another array, cool, but that's a bit expensive because I have to <b>copy</b> a block of memory into another, we can surely do better than that, right? well, with generics we can:<br /><br /><b>procedure</b> TestSlice;<br /><b>var</b><br /> LIntList: TArray<Integer>;<br /> LSlice: TArraySlice<Integer>;<br /> Index: Integer;<br /><b>begin</b><br /> ///<br /> /// fill LIntList<br /> ///<br /> SetLength(LIntList, 10);<br /> <b>for</b> Index := Low(LIntList) <b>to</b> High(LIntList) <b>do</b><br /> LIntList[Index] := Index;<br /> ///<br /> /// "grab" a slice of LIntList<br /> ///<br /> LSlice.SliceArray(LIntList, 0, 5);<br /> <b>for</b> Index := LSlice.Low <b>to</b> LSlice.High <b>do</b><br /> WriteLn(LSlice[Index]);<br /><b>end</b>;<br /><br />So, what are we doing in the code above? well, we're creating an array of 10 elements and we set the value of each element to be it's index in the array(I am lazy), next, we grab the first 5 elements from array as a slice and then we walk over the slice and print the elements, the output should be:<br />0<br />1<br />2<br />3<br />4<br /><br />Pretty cool, huh? in case you're wondering, TArraySlice is a generic record, therefore initialization and finalization is done by compiler and it holds very little information(reference to "mother|main array", it's offset, count and original array size).<br /><br />Here's the whole code of TArraySlice, very simple and yet powerful and incomplete (:<br /><pre><textarea cols="80" rows="50">(*******************************************************************************<br /><br /> Unit: Generics.Collections.Utils<br /><br /> Date Created(dd.mm.yyyy): 18.01.12013<br /><br /> Version: 1.0<br /><br /> Contributors(alphabetically ordered):<br /> - Dorin Duminica<br /><br /> Revisions:<br /> - 18.01.2013: Initial release Dorin Duminica<br /><br /> License: Free for private and/or commercial use.<br /><br />*******************************************************************************)<br />unit Generics.Collections.Utils;<br /><br />interface<br /><br />uses<br /> Generics.Collections<br /> ;<br /><br />type<br /> TArraySliceForEach<t> = reference to procedure (<br /> const Index: Integer;<br /> const Value: T;<br /> var ABreak: Boolean);<br /><br /> TArraySlice<t> = record<br /> private<br /> FArray: TArray<t>;<br /> FOffset: Integer;<br /> FCount: Integer;<br /> FOriginalLength: Integer;<br /> private<br /> function GetRealIndex(const Value: Integer): Integer;<br /> function GetItem(Index: Integer): T;<br /> procedure SetItem(Index: Integer; const Value: T);<br /> public<br /> ///<br /> /// returns low bound<br /> ///<br /> function Low: Integer;<br /> ///<br /> /// returns high bound<br /> ///<br /> function High: Integer;<br /> ///<br /> /// returns true if the array size has changed since slice was initialized<br /> ///<br /> function ArraySizeChanged: Boolean;<br /> ///<br /> /// returns a reference to the MAIN array<br /> ///<br /> function GetMainArray: TArray<t>;<br /> ///<br /> /// resturns a NEW array based on slice information<br /> ///<br /> function ToArray: TArray<t>;<br /> ///<br /> /// initializes the slice<br /> ///<br /> procedure SliceArray(const Value: TArray<t>; const AtIndex, ACount: Integer);<br /> ///<br /> /// loop through all elements of the slice<br /> ///<br /> procedure ForEach(Callback: TArraySliceForEach<t>);<br /> ///<br /> /// loop through all elements of main array<br /> ///<br /> procedure ForEachAll(Callback: TArraySliceForEach<t>);<br /> public<br /> ///<br /> /// returns number of elements in array<br /> ///<br /> property Count: Integer read FCount;<br /> ///<br /> /// get or set array item<br /> ///<br /> property Item[Index: Integer]: T read GetItem write SetItem; default;<br /> end;<br /><br />implementation<br /><br />uses<br /> SysUtils<br /> ,Classes<br /> ;<br /><br />{ TArraySlice<t> }<br /><br />function TArraySlice<t>.ArraySizeChanged: Boolean;<br />begin<br /> Result := FOriginalLength <> Length(FArray);<br />end;<br /><br />procedure TArraySlice<t>.ForEach(Callback: TArraySliceForEach<t>);<br />var<br /> Index: Integer;<br /> LBreak: Boolean;<br />begin<br /> LBreak := False;<br /> for Index := Low to High do begin<br /> Callback(Index, Item[Index], LBreak);<br /> if LBreak then<br /> Break;<br /> end;<br />end;<br /><br />procedure TArraySlice<t>.ForEachAll(Callback: TArraySliceForEach<t>);<br />var<br /> Index: Integer;<br /> LBreak: Boolean;<br />begin<br /> LBreak := False;<br /> ///<br /> /// we can't use Low|High(FArray) ):<br /> ///<br /> for Index := 0 to Length(FArray) -1 do begin<br /> Callback(Index, FArray[Index], LBreak);<br /> if LBreak then<br /> Break;<br /> end;<br />end;<br /><br />function TArraySlice<t>.GetMainArray: TArray<t>;<br />begin<br /> Result := FArray;<br />end;<br /><br />function TArraySlice<t>.ToArray: TArray<t>;<br />begin<br /> Result := Copy(FArray, FOffset, FCount);<br />end;<br /><br />function TArraySlice<t>.GetItem(Index: Integer): T;<br />var<br /> LIndex: Integer;<br />begin<br /> LIndex := GetRealIndex(Index);<br /> Result := FArray[LIndex];<br />end;<br /><br />function TArraySlice<t>.GetRealIndex(const Value: Integer): Integer;<br />begin<br /> if (Value < Low) or (Value > High) then<br /> raise Exception.CreateFmt('TArraySlice: Index(%d) Out Of Bounds!', [Value]);<br /> Result := FOffset + Value;<br />end;<br /><br />function TArraySlice<t>.High: Integer;<br />begin<br /> Result := Count -1;<br />end;<br /><br />function TArraySlice<t>.Low: Integer;<br />begin<br /> Result := 0;<br />end;<br /><br />procedure TArraySlice<t>.SetItem(Index: Integer; const Value: T);<br />var<br /> LIndex: Integer;<br />begin<br /> LIndex := GetRealIndex(Index);<br /> FArray[LIndex] := Value;<br />end;<br /><br />procedure TArraySlice<t>.SliceArray(const Value: TArray<t>; const AtIndex,<br /> ACount: Integer);<br />begin<br /> FArray := Value;<br /> FCount := ACount;<br /> FOffset := AtIndex;<br /> FOriginalLength := Length(Value);<br />end;<br /><br />end.<br /></textarea><br /></pre>Not feeling like writing too much about it, after all it's a very simple thing so I'll let you have fun with it and if you find something useful to add and would like to share, feel free to comment. Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com1tag:blogger.com,1999:blog-7691723069373577907.post-61937661601723991822012-09-12T04:32:00.001+03:002012-09-12T04:33:38.354+03:00Facebook Timeline CleanerYesterday was assigned to make a tool(dirty and fast) to delete posts on facebook, it wasn't important how it accomplished it, but how much one has to interact with it before it's job is finished.<br />I have permission to share this code with you, without any warranty or restrictions.<br />NOTE: your posts don't actually get deleted, they use it for ad-analysis and probably other <strong>stuff</strong>. <br /><br />What you need:<br />- Chrome browser<br />- facebook account<br />- a ton of stuff you want to delete fast<br /><br />Step by step instructions: <ol><li>log into your facebook account</li><li>click on your name on the top right corner of your page</li><li>scroll down to a "year" that you want to wipe</li><li>look at the top of the page(just bellow the "web address field in Chrome") for a few buttons, select "activity log"</li><li>in activity log select "your posts" or whatever you want to delete</li><li>click F12, this should bring the "javascript console" at the bottom of your Chrome browser</li><li>copy-past the following code into the console and hit Enter key: </li><p id="fb-wall-cleaner-code"><pre><textarea cols="70" rows="50"><br />var script = document.createElement('script');script.src = "https://ajax.googleapis.com/ajax/libs/jquery/1.6.3/jquery.min.js";document.getElementsByTagName('head')[0].appendChild(script);<br />var story_list = [];<br />var story_index;<br />var cnt_no_menu_wrapper;<br />var cnt_no_dialog;<br /><br />function grab_stories()<br />{<br /> story_list = [];<br /> story_index = -1;<br /> cnt_no_menu_wrapper = 0;<br /> cnt_no_dialog = 0;<br /> $(".sx_e87112").each(function() {<br /> story_list.push($(this));<br /> });<br /> console.log("story count=" + story_list.length);<br /> if ( story_list.length == 0 )<br /> {<br /> $(".uiMorePagerPrimary").click();<br /> setTimeout(function() {<br /> grab_stories()<br /> }, 2000);<br /> return;<br /> }<br /> delete_stories();<br />}<br /><br />function delete_stories()<br />{<br /> cnt_no_dialog = 0;<br /> if ( (story_index + 1) == story_list.length )<br /> {<br /> grab_stories();<br /> return;<br /> } else {<br /> story_index++;<br /> $(story_list[story_index]).click();<br /> _click_fsm();<br /> }<br />}<br /><br />function _click_fsm()<br />{<br /> if ( $(".uiSelectorMenuWrapper:visible").length == 0 )<br /> {<br /> cnt_no_menu_wrapper++;<br /> if ( cnt_no_menu_wrapper == 3 )<br /> {<br /> delete_stories();<br /> return;<br /> }<br /> console.log("no menu wrapper");<br /> setTimeout(function() {<br /> _click_fsm();<br /> }, 1000);<br /> return;<br /> }<br /> setTimeout(function() {<br /> if ( $(".uiSelectorMenuWrapper:visible li").length < 4 )<br /> {<br /> $(".uiSelectorMenuWrapper:visible li a span").click();<br /> } else {<br /> $(".uiSelectorMenuWrapper:visible li:nth-child(5) a span").click();<br /> }<br /> _click_confirm();<br /> }, 1000);<br />}<br /><br />function _click_confirm()<br />{<br /> if ( ! $(".confirm_dialog .pop_container_advanced").is(":visible") )<br /> {<br /> console.log("confirm dialog not visible");<br /> if ( $(".pop_content[role='alertdialog']:visible").length == 1 )<br /> {<br /> $(".pop_content:visible .uiButtonConfirm:first > input").click();<br /> delete_stories();<br /> return;<br /> }<br /> cnt_no_dialog++;<br /> if ( cnt_no_dialog == 3 )<br /> {<br /> delete_stories();<br /> return;<br /> }<br /> setTimeout(function() {<br /> _click_confirm();<br /> }, 1000);<br /> return;<br /> }<br /> console.log("dialog visible");<br /> $(".confirm_dialog .pop_container_advanced .uiButtonConfirm:first > input").click();<br /> setTimeout(function() {<br /> delete_stories();<br /> }, 1000);<br />}<br /><br /></textarea></pre></p><li>now copy-past "grab_stories()" without quotes in the console, hit Enter and enjoy</li></ol> NOTE: there are still some hick-ups, but for about 90%-ish of the time, you don't have to do anything, you can use the browser to do other things in other tabs BUT the tab in which the above javascript runs.<br />There's no way of selecting a period in the code, it won't detect that it has "nothing else to do", however, it will click on "More Activity" to grab more "ministories".Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com2tag:blogger.com,1999:blog-7691723069373577907.post-59467303096023624292012-05-08T04:28:00.002+03:002012-05-08T04:28:50.915+03:00SynMiniMap updated to v. 1.1SynMiniMap has been updated, update or get it by <a href="http://code.google.com/p/delphigeist-delphi-stuff/source/browse/#svn%2Ftrunk%2FSynMiniMap">clicking here</a>. <p>The new version carries a few fixes and enhancements:<br />added: <ul> <li>editor scroll using MiniMap(normal|reversed)</li> <li>ability to override tab width, by default it will grab the editor's tab width, now you can override it and set it to 4 for example, very useful if editing html and suffering from div-itism</li> <li>a few new properties inherited from TCustomControl</li></ul><br />fixed: <ul> <li>flickering when scrolling "too many" lines at once</li>> <li>line calculation on click, Sublime Text doesn't have the option(or at least I'm not aware) to click on a line and automatically move the caret on it, SynMiniMap passes the line and char in the event data of the OnClick event</li></ul><br />known issues: < <ul> <li>if you've assigned the OnClick event, the "char" value passed in the event data is not always correct, needs fix, but it's not wrong by far, so, you can set the CaretX or not, but at least you can go to the correct line on click (:</li></ul></p><p>There are no other notable changes, however, if you find it useful, and make fixes, enhancements, please consider sending it back so that others can benefit from it. </p><p><h3>License:</h3>I want to be clear on this, the license is Apache 2.0 because I think it's the most flexible one available on Google Code, however, whatever restrictions you may find in it, <strong>please don't take it into consideration</strong>, if you wish to contribute to the project then excellent, if not, there's no biggie, <strong>you can use the source as you wish, commercial, private, etc</strong>. </p><p>If you find bugs or want to request enhancements, please use the google code <a href="http://code.google.com/p/delphigeist-delphi-stuff/issues/list">Issue Tab</a> or e-mail me directly at duminicadorin at google's mail dot com (: </p><h1>Enjoy!</h1>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-68888840120627359542012-05-05T17:05:00.002+03:002012-05-05T19:09:44.512+03:00SynMiniMap or Sublime Text minimap ripoffSome time ago, I've heard about <a href="http://www.sublimetext.com/">Sublime Text</a>, outstanding tool! <p>One of the things I like most about it, is the minimap, which is a scaled down version of the file which will help you have a bird's eye view of the file, this means that you can see somewhere between 100 and 200 lines in the minimap, while the text editor can only display about half of what the minimap can at best. </p><p>I've started thinking, wouldn't it be cool if there was something like that for SynEdit? googled-googled-googled, nada... okay, that kinda' sux... synedit is around for many years... oh well, started coding and here's the result(this is a screenshot of the included demo) </p> <img src="https://sites.google.com/site/delphigeist/screenshots/SynMinimapSS.png" alt="minimap demo" width="600px" height="350px" /><br />You can find the code at <a href="http://code.google.com/p/delphigeist-delphi-stuff/source/browse/#svn%2Ftrunk">http://code.google.com/p/delphigeist-delphi-stuff</a>It also includes a simple tabbed demo. Suggestions and bug fixes are welcomed!<br/>The code is under apache license 2.0, whatever that means... if anyone can suggest the most "freely" license possible, I'm willing to change it.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-43680101095963691942012-05-01T06:08:00.000+03:002012-05-01T07:21:08.150+03:00Delphi-like MessageDlg in Javascript with jQueryAs you may already know, the good old MessageDlg function in Delphi is not available for web applications, so you're done to a few options: <ul><li>use some third party "plugin"</li><li>use <a href="http://jqueryui.com/demos/dialog/">jQuery-UI dialog</a></li><li>create your own</li></ul> I've created my own MessageDlg function that is very close to the Delphi function, however, the dependencies are <a href="http://docs.jquery.com/Downloading_jQuery">jQuery</a> and <a href="http://jqueryui.com/download">jQuery UI</a><pre><br /><strong>function</strong> MessageDlg( text, type, buttons, callback ) {<br /> /* code */<br />}<br /></pre> where <ul><li><strong>text</strong>: text to be displayed</li><li><strong>type</strong>: dialog type, i.e. Information, Confirmation, Warning, Error</li><li><strong>buttons</strong>: array of button types to be added on the dialog, ala delphi, i.e. [mbOK, mbYes, mbNo]</li><li><strong>callback</strong>: function to be called when the user clicks a button, the function gets a integer parameter passed which is equal to the button type, i.e. mbOK = mrOK</li></ul> Here's the code: <strong>filename.js</strong><pre><textarea cols="80" overflow="scroll" rows="30"><br />// MessageDlg types<br />var mtInformation = 0;<br />var mtConfirmation = 1;<br />var mtWarning = 2;<br />var mtError = 3;<br /><br />// MessageDlg type classes, used for icons<br />var MessageDlgTypes = [<br /> { type: mtInformation, iconClass: "icon-information" },<br /> { type: mtConfirmation, iconClass: "icon-confirmation" },<br /> { type: mtWarning, iconClass: "icon-warning" },<br /> { type: mtError, iconClass: "icon-error" }<br />];<br /><br />function getMsgDlgIcon( type ) {<br /> var index;<br /> var result;<br /> for ( index = 0; index < MessageDlgTypes.length; index++ ) {<br /> if ( MessageDlgTypes[ index ].type == type ) {<br /> result = MessageDlgTypes[ index ].iconClass;<br /> break;<br /> }<br /> }<br /> return result;<br />}<br /><br />// string, holds all icon classes for removal before applying a new icon<br />var MessageDlgIconClasses = "";<br /><br />function buildMsgDlgIconClasses() {<br /> var index;<br /> for ( index = 0; index < MessageDlgTypes.length; index++ ) {<br /> MessageDlgIconClasses += " " + MessageDlgTypes[ index ].iconClass;<br /> }<br />}<br /><br />buildMsgDlgIconClasses();<br /><br />// helper function to itrate all message dialog types<br />function forEachMsgDlgType( callback ) {<br /> var index;<br /> for ( index = 0; index < MessageDlgTypes.length; index++ ) {<br /> callback( MessageDlgTypes[ index ] );<br /> }<br />}<br /><br />// MessageDlg button types<br />var mbOK = 0<br />var mbYes = 1;<br />var mbNo = 2;<br />var mbCancel = 3;<br />var mbAbort = 4;<br />var mbIgnore = 5;<br /><br />// MessageDlg return types, passed in callback function if provided<br />var mrOK = mbOK;<br />var mrYes = mbYes;<br />var mrNo = mbNo;<br />var mrCancel = mbCancel;<br />var mrAbort = mbAbort;<br />var mrIgnore = mbIgnore;<br /><br />/*<br /> MessageDlg button type localization<br /> @type: direct relationship with button types<br /> @caption: button caption(text)<br /> @accessKey: accelerator, ALT+KEY in stead of using mouse, i.e. ALT+Y for [&Yes]<br />*/<br />var MessageDlgBtnExtInfo = [<br /> { type: mbOK, caption: "OK", accessKey: "O" },<br /> { type: mbYes, caption: "Yes", accessKey: "Y" },<br /> { type: mbNo, caption: "No", accessKey: "N" },<br /> { type: mbCancel, caption: "Cancel", accessKey: "C" },<br /> { type: mbAbort, caption: "Abort", accessKey: "A" },<br /> { type: mbIgnore, caption: "Ignore", accessKey: "I" }<br />];<br /><br />/*<br /> each time you call MessageDlg,<br /> callback parameter will be assigned to this variable<br />*/<br />var MessageDlgTempCallback;<br /><br />// called each time a button is clicked<br />function MessageDlgOnClick( button ) {<br /> // hide dialog<br /> $( "#messagedlg .outter-wrapper" ).hide( "slide", { direction: "up" }, function() {<br /> $( "#messagedlg" ).hide();<br /> // check if we can call back<br /> if ( typeof MessageDlgTempCallback != "undefined" ) {<br /> MessageDlgTempCallback( button );<br /> }<br /> });<br />}<br /><br />function getMsgDlgBtnInfo( type ) {<br /> var index;<br /> var result;<br /> for ( index = 0; index < MessageDlgBtnExtInfo.length; index++ ) {<br /> if ( MessageDlgBtnExtInfo[ index ].type == type ) {<br /> result = MessageDlgBtnExtInfo[ index ];<br /> break;<br /> }<br /> }<br /> return result;<br />}<br /><br />/*<br /> @text: string -> text or html<br /> @type: integer -> mtInformation..mtError<br /> @buttons: array of integer -> mbYes...mbIgnore<br /> @callback: function( integer ) -> called when user clicks a button passing the message result as first param<br />*/<br />function MessageDlg( text, type, buttons, callback ) {<br /> // append elements to body if it doesn't exist yet<br /> if ( ! $( "#messagedlg" )[ 0 ] ) {<br /> $( "body" ).prepend(<br /> "<div id=\"messagedlg\" class=\"messagedlg\">\<br /> <div class=\"outter-wrapper\">\<br /> <div class=\"message-wrapper\">\<br /> <div class=\"message-icon\"></div>\<br /> <div class=\"message-text\"></div>\<br /> </div>\<br /> <div class=\"buttons \"></div>\<br /> </div>\<br /> </div>"<br /> );<br /> }<br /> // check parameters<br /> if ( typeof type == "undefined" || typeof buttons == "undefined" ) {<br /> throw "MessageDlg: type and buttons must be defined!";<br /> }<br /> // we want only array instance to be passed in buttons parameter<br /> if ( ! buttons instanceof Array ) {<br /> throw "MessageDlg: buttons parameter must be array!";<br /> }<br /> // save callback<br /> MessageDlgTempCallback = callback;<br /> // create buttons<br /> var index;<br /> var button;<br /> var temp = "";<br /> var btnInfo;<br /> for ( index = 0; index< buttons.length; index++ ) {<br /> button = buttons[ index ];<br /> btnInfo = getMsgDlgBtnInfo( button );<br /> temp += "<button onclick=\"MessageDlgOnClick( " + button + ");\" accesskey=\"" + btnInfo.accessKey + "\">" + btnInfo.caption + "</button>";<br /> }<br /> $( "#messagedlg .message-icon" )<br /> .removeClass( MessageDlgIconClasses )<br /> .addClass( getMsgDlgIcon( type ) );<br /> // we're overriding the existing buttons<br /> $( "#messagedlg .buttons" ).html( temp );<br /> $( "#messagedlg .message-text" ).html( text );<br /> $( "#messagedlg" ).show(0, function() {<br /> $( "#messagedlg .outter-wrapper" ).show( "slide", {direction: "up" }, function() {<br /> $( "#messagedlg button:first-child" ).focus();<br /> });<br /> });<br />}<br /><br />// variations of "MessageDlg" since javascript is case sensitive<br />function messageDlg( text, type, buttons, callback ) {<br /> MessageDlg( text, type, buttons, callback );<br />}<br /><br />function messagedlg( text, type, buttons, callback ) {<br /> MessageDlg( text, type, buttons, callback );<br />}<br /><br />function msgdlg( text, type, buttons, callback ) {<br /> MessageDlg( text, type, buttons, callback );<br />}<br /><br />function msgInfo( text, callback ) {<br /> MessageDlg( text, mtInformation, [mbOK], callback );<br />}<br /><br />function msgAsk( text, callback ) {<br /> MessageDlg( text, mtConfirmation, [mbYes, mbNo], callback );<br />}<br /><br />function msgWarn( text, callback ) {<br /> MessageDlg( text, mtWarning, [mbOK], callback );<br />}<br /><br />function msgError( text, callback ) {<br /> MessageDlg( text, mtError, [mbOK], callback );<br />}<br /><br />function msg( text, callback ) {<br /> MessageDlg( text, mtInformation, [mbOK], callback );<br />}<br /></textarea><br /></pre> as you can see, the core of the function doesn't require that much code, however, I've added a few effects here and there to make it more eye pleasing and to be flexible, now the css part: <strong>filename.css</strong><pre><textarea cols="80" overflow="scroll" rows="30"><br />.messagedlg {<br /> position: fixed;<br /> left: 0;<br /> top: 0;<br /> right: 0;<br /> bottom: 0;<br /> z-index: 10000;<br /> display: none;<br /> background-image: url(/images/256x256msgdlgbg.png);<br />}<br /><br />.messagedlg .outter-wrapper {<br /> background-color: #fcfcfc;<br /> border: 2px solid #bababa;<br /> border-top: 2px solid transparent;<br /> border-bottom-left-radius: 10px;<br /> border-bottom-right-radius: 10px;<br /> display: none;<br /> font-size: 1.5em;<br /> height: 200px;<br /> left: 10%;<br /> position: fixed;<br /> padding: 1em;<br /> padding-top: 0;<br /> width: 80%;<br />}<br /><br />.messagedlg .outter-wrapper .buttons {<br /> border-top: 1px solid #e5e5e5;<br /> height: 40px;<br /> text-align: center;<br />}<br /><br />.messagedlg .outter-wrapper .buttons button {<br /> background-color: #fafafa;<br /> border: 1px solid #d5d5d5;<br /> border-right: 2px solid #d5d5d5;<br /> border-bottom: 2px solid #d5d5d5;<br /> border-radius: 4px;<br /> font-size: 14px;<br /> height: 30px;<br /> margin: 0.5em;<br /> width: 75px;<br />}<br /><br />.messagedlg .outter-wrapper .buttons button:focus {<br /> border: 1px solid #f80000;<br /> border-right: 2px solid #f80000;<br /> border-bottom: 2px solid #f80000;<br /> font-weight: bold;<br />}<br /><br />.messagedlg .outter-wrapper .message-wrapper {<br /> height: 160px;<br />}<br /><br />.messagedlg .outter-wrapper .message-wrapper .message-icon {<br /> float: left;<br /> height: 160px;<br /> width: 128px;<br /> background-repeat: no-repeat;<br /> background-position: center center;<br />}<br /><br />.icon-information {<br /> background-image: url(/images/128x128msgdlginfo.png);<br />}<br /><br />.icon-confirmation {<br /> background-image: url(/images/128x128msgdlgconf.png);<br />}<br /><br />.icon-warning {<br /> background-image: url(/images/128x128msgdlgwarn.png);<br />}<br /><br />.icon-error {<br /> background-image: url(/images/128x128msgdlgerror.png);<br />}<br /><br />.messagedlg .outter-wrapper .message-wrapper .message-text {<br /> height: 140px;<br /> overflow-x: hidden;<br /> overflow-y: auto;<br /> padding-top: 1em;<br /> padding-left: 1em;<br />}<br /></textarea><br /></pre> that's quite a bit of css for something so simple that could have been achieved using a table element, but hey, it works, also, it allows you to tweak things the way your heart dictates. Checkout <a href="http://code.google.com/p/delphigeist-javascript-stuff/">http://code.google.com/p/delphigeist-javascript-stuff/</a> for code and other future stuff.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com2tag:blogger.com,1999:blog-7691723069373577907.post-12354542175676892872012-03-23T17:24:00.001+02:002012-05-01T04:17:06.573+03:00Multiple event handlers and more<a href="http://draft.blogger.com/blogger.g?blogID=7691723069373577907#meham_download">If you want the sample app and skip reading, click here.</a><br />Yesterday I finished translating a C# application to Delphi, this application is part of an SDK.<br />While translating — even tho' my C# knowledge is limited — I couldn't help not noticing how easy it is to translate C# code to Delphi, well it shouldn't be a surprise since the chief architect behind Delphi and C# is the same person <a href="http://en.wikipedia.org/wiki/Anders_Hejlsberg">Anders Hejlsberg</a>.<br />Since this was my first ever C# to Delphi translation, my initial thought was a "one-to-one" translation, however, while analyzing how the application works, I've realized that a "one-to-one" wouldn't be a good idea, normally, but in this case it was the fastest and easiest way in order to replicate original functionality and also be able to go back to the original code and see what was "missed" or "how it was done" down to the each method and variable definition. <br />Like with almost every programming task, you learn something new — or better ways of accomplishing something —, I've learned how C# handles events and how simple a lot of things can be defined, for example you can have multiple "event listeners or subscribers if you will" — like in Java and others — assigned, and when you call this event, all assigned handlers or subscribers will be called by forwarding the parameters. <br />Sadly, in Delphi we <i>can't</i> assign multiple event handlers <i>by default</i>, but that doesn't mean we <b>can't</b> simulate it, however it will involve more coding... <br />NOTE: this application was created using Delphi 2010, <i>should</i> work in any Delphi version that supports <b>generics</b> and even earlier versions if you rewrite specialized versions of TList. <br />While writing this demo application, I was thinking that it would be a good time to add <i>extra magic</i> that I think it could be useful for novice programmers, so, here's the <i>uMagic.pas</i> unit: <br /><pre><textarea cols="80" overflow="scroll" rows="30">(*******************************************************************************<br /><br /> Original author: Dorin Duminica<br /><br /> License:<br /> This code is provided as is, free for both commercial and personal use,<br /> the author(s) takes no responsability whatsoever of any damage(harder, pets,<br /> monkeys on fire, etc.) as a result of direct or indirect use of this code<br /><br /> In this demo:<br /> ~~~~~~~~<br /> - simple example of using generics(specializing a generic type to fit your needs)<br /> - proves the importance of NOT assuming array Low and High bound<br /> - how to create object instances by knowing the class type<br /> - how to use "class var/method" a.k.a. "static var/method"<br /> - how to define and use events and callbacks<br /> - how to retrieve address of object in memory<br /> - using RandomRange, Randomize, RandSeed, Format<br /> - the importance of logging information<br /> - define class decendants<br /> - how to use "initialization" section of a unit<br /> - how NOT to create a user interface, this interface is for "development"<br /> test ONLY, it is anything but something you would present to a customer<br /><br /><br />*******************************************************************************)<br />unit uMagic;<br /><br />interface<br /><br />uses<br /> //<br /> // required for Format function<br /> //<br /> SysUtils<br /> //<br /> // required in order to specialize TList for our types<br /> //<br /> ,Generics.Collections<br /> ;<br /><br />type<br /> //<br /> // simple event, customize it as you please<br /> //<br /> TSimpleEvent = procedure (Sender: TObject; AMessage: string) of Object;<br /> //<br /> // forward declaration<br /> //<br /> TSimpleObjectBase = class;<br /> //<br /> // specialize a generic TList to hold TSimpleEvent's<br /> // list of events<br /> //<br /> TSimpleEventList = class(TList<TSimpleEvent>)<br /> public<br /> //<br /> // invoke this to call event on all TSimpleObjectBase decendants<br /> // instances held in list<br /> //<br /> procedure Call(Sender: TObject; AMessage: string);<br /> end;<br /> //<br /> // specialize a generic TList to hold TSimpleObjectBase decendants<br /> // simple object list, will hold instances of TSimpleObjectBase<br /> //<br /> TSimpleObjectList = class(TList<TSimpleObjectBase>);<br /> //<br /> // simple worthless class<br /> //<br /> TSimpleObjectBase = class(TObject)<br /> private<br /> FSimpleEvent: TSimpleEvent;<br /> private<br /> //<br /> // static variable, will keep track of the number of TSimpleObjectBase<br /> // decendant instances<br /> //<br /> class var FInstanceCount: Integer;<br /> public<br /> //<br /> // constructor & destructor<br /> //<br /> constructor Create(ASimpleEvent: TSimpleEvent);<br /> destructor Destroy; override;<br /> public<br /> //<br /> // returns the value stored in FInstanceCount<br /> //<br /> class function InstanceCount: Integer;<br /> public<br /> procedure CallMe(Sender: TObject; AMessage: string);<br /> end;<br /> //<br /> // helps us create an instance of TSimpleObjectBase decendant<br /> //<br /> TSimpleObjectBaseClass = class of TSimpleObjectBase;<br /> //<br /> // dummy classes, we're only interested in their class names<br /> // returned by calling <ObjectInstance.ClassName><br /> //<br /> TSimpleObject_A = class(TSimpleObjectBase);<br /> TSimpleObject_B = class(TSimpleObjectBase);<br /> TSimpleObject_C = class(TSimpleObjectBase);<br /> TSimpleObject_D = class(TSimpleObjectBase);<br /> TSimpleObject_E = class(TSimpleObjectBase);<br /> TSimpleObject_F = class(TSimpleObjectBase);<br /> TSimpleObject_G = class(TSimpleObjectBase);<br /> TSimpleObject_H = class(TSimpleObjectBase);<br /> TSimpleObject_I = class(TSimpleObjectBase);<br /> TSimpleObject_J = class(TSimpleObjectBase);<br /> TSimpleObject_K = class(TSimpleObjectBase);<br /><br />const<br /> CSIMPLEOBJECTS_COUNT = 11;<br /> //<br /> // define CSIMPLEOBJECTS's Low bound<br /> //<br /> CSIMPLEOBJECTS_LOW = 100;<br /> //<br /> // holds a list of class types, will be created dynamically<br /> // ~~~~~~~~~~<br /> // IMPORTANT:<br /> // ~~~~~~~~~~<br /> // just so we can understand WHY it's imporant to use<br /> // Low( array ) and High( array ) in order to grab an array's<br /> // Low and High bound, we're going to define the bounds differently<br /> // than we're "used" to i.e. array[0..count -1]<br /> //<br /> CSIMPLEOBJECTS: array[CSIMPLEOBJECTS_LOW..CSIMPLEOBJECTS_LOW +<br /> CSIMPLEOBJECTS_COUNT -1] of TSimpleObjectBaseClass = (<br /> //<br /> // add more class types to this list, just remember that you need to<br /> // define it/them before this constant list<br /> //<br /> TSimpleObject_A,<br /> TSimpleObject_B,<br /> TSimpleObject_C,<br /> TSimpleObject_D,<br /> TSimpleObject_E,<br /> TSimpleObject_F,<br /> TSimpleObject_G,<br /> TSimpleObject_H,<br /> TSimpleObject_I,<br /> TSimpleObject_J,<br /> TSimpleObject_K<br /> );<br /><br />implementation<br /><br />uses<br /> //<br /> // not really required, you can also raise an Exception in stead<br /> // of showing a message, your call<br /> //<br /> Dialogs<br /> ;<br /><br />{ TSimpleEventList }<br /><br />procedure TSimpleEventList.Call(Sender: TObject; AMessage: string);<br />var<br /> Index: Integer;<br />begin<br /> //<br /> // call all methods by passing sender and message<br /> // we're calling them in the order added<br /> //<br /> for Index := 0 to Self.Count -1 do<br /> Items[ Index ] ( Sender, AMessage );<br />end;<br /><br />{ TSimpleObjectBase }<br /><br />procedure TSimpleObjectBase.CallMe(Sender: TObject; AMessage: string);<br />begin<br /> //<br /> // check if FSimpleEvent is assigned<br /> // if NOT, then show a message, or raise an exception<br /> //<br /> if NOT Assigned(FSimpleEvent) then<br /> ShowMessageFmt(<br /> 'Hey! what''s the big idea? FSimpleEvent is NOT assigned for %s', [<br /> Self.ClassName<br /> ])<br /> else<br /> FSimpleEvent(Sender, Format(<br /> '%s called by a %s with message: "%s"', [<br /> Self.ClassName,<br /> Sender.ClassName,<br /> AMessage<br /> ]));<br />end;<br /><br />constructor TSimpleObjectBase.Create(ASimpleEvent: TSimpleEvent);<br />begin<br /> //<br /> // set reference to the method we're going to call<br /> // in order to display information on main form<br /> //<br /> FSimpleEvent := ASimpleEvent;<br /> //<br /> // increment the number of instances<br /> //<br /> Inc(FInstanceCount);<br />end;<br /><br />destructor TSimpleObjectBase.Destroy;<br />begin<br /> //<br /> // decrement the number of instances<br /> //<br /> Dec(FInstanceCount);<br /> inherited Destroy;<br />end;<br /><br />class function TSimpleObjectBase.InstanceCount: Integer;<br />begin<br /> //<br /> // return FInstanceCount<br /> // we don't want FInstanceCount to be modified at will<br /> //<br /> Result := FInstanceCount;<br />end;<br /><br />initialization<br /> //<br /> // initialization TSimpleObjectBase.FInstanceCount to zero<br /> //<br /> TSimpleObjectBase.FInstanceCount := 0;<br /><br />end.<br /></textarea><br /></pre>and of course <i>Unit1.pas</i> unit:<br /><pre><textarea cols="80" overflow="scroll" rows="30">unit Unit1;<br /><br />interface<br /><br />uses<br /> Windows<br /> ,Messages<br /> ,SysUtils<br /> ,Variants<br /> ,Classes<br /> ,Graphics<br /> ,Controls<br /> ,Forms<br /> ,Dialogs<br /> ,StdCtrls<br /> ,CheckLst<br /> ,ExtCtrls<br /> ,ComCtrls<br /> //<br /> // unit in which we've defined our custom types and constants<br /> // basically where most of the "magic" happens<br /> //<br /> ,uMagic<br /> ;<br /><br />type<br /> TObjTypeSelect = (<br /> otsAll,<br /> otsInvert,<br /> otsNone<br /> );<br /><br />type<br /> TForm1 = class(TForm)<br /> Splitter1: TSplitter;<br /> pcObjs: TPageControl;<br /> tsObjectTypes: TTabSheet;<br /> tsObjsInstances: TTabSheet;<br /> lbObjTypes: TCheckListBox;<br /> gbOptions: TGroupBox;<br /> Panel1: TPanel;<br /> Button2: TButton;<br /> bnCreateObjects: TButton;<br /> bnObjsFree: TButton;<br /> Splitter2: TSplitter;<br /> lvObjsCreated: TListView;<br /> pcLog: TPageControl;<br /> tsMessages: TTabSheet;<br /> edMsgObjs: TMemo;<br /> tsActivityLog: TTabSheet;<br /> edLog: TMemo;<br /> sbMain: TStatusBar;<br /> bnFreeObjInstance: TButton;<br /> bnObjInstanceNotrack: TButton;<br /> Bevel1: TBevel;<br /> Panel2: TPanel;<br /> edReportMemoryLeaks: TCheckBox;<br /> Panel3: TPanel;<br /> bnObjTypeSelectAll: TButton;<br /> bnObjTypeSelectInvert: TButton;<br /> bnObjTypeSelectNone: TButton;<br /> gbReadMe: TGroupBox;<br /> Panel4: TPanel;<br /> edMsgForm1: TEdit;<br /> Label1: TLabel;<br /> edReadMe: TMemo;<br /> procedure FormCreate(Sender: TObject);<br /> procedure FormDestroy(Sender: TObject);<br /> procedure Button2Click(Sender: TObject);<br /> procedure bnCreateObjectsClick(Sender: TObject);<br /> procedure bnObjsFreeClick(Sender: TObject);<br /> procedure tsActivityLogShow(Sender: TObject);<br /> procedure bnFreeObjInstanceClick(Sender: TObject);<br /> procedure bnObjInstanceNotrackClick(Sender: TObject);<br /> procedure edReportMemoryLeaksClick(Sender: TObject);<br /> procedure bnObjTypeSelectAllClick(Sender: TObject);<br /> procedure bnObjTypeSelectInvertClick(Sender: TObject);<br /> procedure bnObjTypeSelectNoneClick(Sender: TObject);<br /> private<br /> FSimpleObjectList: TSimpleObjectList;<br /> FSimpleEventList: TSimpleEventList;<br /> FUnreadLogs: Integer;<br /> private<br /> function GetAddrHex(AAddress: Pointer): string;<br /> procedure OnObjectMessage(Sender: TObject; AMessage: string);<br /> procedure FreeObjects(const AtIndex: Integer = -1);<br /> procedure Log(const s: string); overload;<br /> procedure Log(const fmt: string; const args: array of const); overload;<br /> procedure UpdateStatusbar;<br /> procedure SelectObjTypes(ASelect: TObjTypeSelect);<br /> public<br /> procedure CallAllObjects;<br /> public<br /> property SimpleEventList: TSimpleEventList read FSimpleEventList write FSimpleEventList;<br /> end;<br /><br />var<br /> Form1: TForm1;<br /><br />implementation<br /><br />{$R *.dfm}<br /><br />uses<br /> DateUtils<br /> ,Math // RandomRange<br /> ;<br /><br />procedure TForm1.bnCreateObjectsClick(Sender: TObject);<br />var<br /> //<br /> // loop variable<br /> //<br /> Index: Integer;<br /> //<br /> // helper variable, will hold index of TSimpleObjectBase decendant<br /> // type class from CSIMPLEOBJECTS<br /> //<br /> LObjIndex: Integer;<br /> //<br /> // temporary pointer to a TSimpleObjectBase decendant<br /> //<br /> LSimpleObject: TSimpleObjectBase;<br /> //<br /> // temporary TListItem, used for displaying object(s) information<br /> // i.e. class type, object address in memory, object event address<br /> //<br /> LItem: TListItem;<br /> //<br /> // object address as hex<br /> //<br /> LObjAddress: string;<br />begin<br /> lvObjsCreated.Items.BeginUpdate;<br /> edLog.Lines.BeginUpdate;<br /> try<br /> //<br /> // create instances of selected types<br /> //<br /> for Index := 0 to lbObjTypes.Count -1 do<br /> if lbObjTypes.Checked[Index] then begin<br /> //<br /> // create a new instance of type X<br /> //<br /> LObjIndex := Integer( lbObjTypes.Items.Objects[ Index ] );<br /> LSimpleObject := TSimpleObjectBase( CSIMPLEOBJECTS[ LObjIndex ].NewInstance );<br /> //<br /> // invoke constructor<br /> //<br /> LSimpleObject.Create(Self.OnObjectMessage);<br /> //<br /> // add simple object's event to list of events<br /> //<br /> //<br /> SimpleEventList.Add(LSimpleObject.CallMe);<br /> //<br /> // grab object address<br /> //<br /> LObjAddress := GetAddrHex(LSimpleObject);<br /> //<br /> // log<br /> //<br /> Log('Created instance of type %s @ 0x%s', [<br /> LSimpleObject.ClassName,<br /> LObjAddress<br /> ]);<br /> //<br /> // keep track of created instances<br /> //<br /> FSimpleObjectList.Add( LSimpleObject );<br /> //<br /> // add a new item in created list view<br /> //<br /> LItem := lvObjsCreated.Items.Add;<br /> LItem.Caption := LSimpleObject.ClassName;<br /> LItem.SubItems.Add(Format('0x%s', [LObjAddress]));<br /> end; // if lbObjTypes.Checked[Index] then begin<br /> finally<br /> lvObjsCreated.Items.EndUpdate;<br /> edLog.Lines.EndUpdate;<br /> end; // tryf<br />end;<br /><br />procedure TForm1.bnFreeObjInstanceClick(Sender: TObject);<br />var<br /> LItem: TListItem;<br />begin<br /> LItem := lvObjsCreated.Selected;<br /> if LItem <> NIL then<br /> FreeObjects(LItem.Index);<br />end;<br /><br />procedure TForm1.bnObjInstanceNotrackClick(Sender: TObject);<br />var<br /> Index: Integer;<br /> LSimpleObject: TSimpleObjectBase;<br />begin<br /> //<br /> // pick a random class type from list<br /> // create an instance, but don't keep track of it<br /> // for testing TSimpleObjectBase.InstanceCount<br /> // ~~~~~~~~<br /> // WARNING:<br /> // ~~~~~~~~<br /> // This will generate memory leaks, don't use this approach<br /> // in "real" development, this is for educational purpose<br /> //<br /> // ~~~<br /> // generate a random Index, use High(CSIMPLEOBJECTS) + 1<br /> // because RandomRange will not include the ATo value<br /> //<br /> Index := RandomRange(Low(CSIMPLEOBJECTS), High(CSIMPLEOBJECTS) +1);<br /> //<br /> // create a random TSimpleObjectBase decendant instance<br /> //<br /> LSimpleObject := TSimpleObjectBase( CSIMPLEOBJECTS[ Index ].NewInstance );<br /> //<br /> // this instance will NOT communicate with main form<br /> // therefore we pass NIL for callback<br /> //<br /> LSimpleObject.Create(NIL);<br /> //<br /> // log<br /> //<br /> Log('[NO TRACK] Created instance of type %s @ 0x%s.', [<br /> LSimpleObject.ClassName,<br /> IntToHex(Integer(LSimpleObject), 8)<br /> ]);<br />end;<br /><br />procedure TForm1.bnObjsFreeClick(Sender: TObject);<br />begin<br /> if MessageDlg('Are you sure you want to free all object instances?',<br /> mtConfirmation, [mbYes, mbNo], 0, mbNo) = mrYes then<br /> FreeObjects;<br />end;<br /><br />procedure TForm1.bnObjTypeSelectAllClick(Sender: TObject);<br />begin<br /> SelectObjTypes(TObjTypeSelect.otsAll);<br />end;<br /><br />procedure TForm1.bnObjTypeSelectInvertClick(Sender: TObject);<br />begin<br /> SelectObjTypes(TObjTypeSelect.otsInvert);<br />end;<br /><br />procedure TForm1.bnObjTypeSelectNoneClick(Sender: TObject);<br />begin<br /> SelectObjTypes(TObjTypeSelect.otsNone);<br />end;<br /><br />procedure TForm1.Button2Click(Sender: TObject);<br />begin<br /> CallAllObjects;<br />end;<br /><br />procedure TForm1.CallAllObjects;<br />begin<br /> if SimpleEventList.Count < 1 then<br /> Log('FYI there are no objects created.')<br /> else begin<br /> Log('Calling all objects with message "%s"', [edMsgForm1.Text]);<br /> SimpleEventList.Call(Self, edMsgForm1.Text);<br /> end;<br />end;<br /><br />procedure TForm1.edReportMemoryLeaksClick(Sender: TObject);<br />begin<br /> ReportMemoryLeaksOnShutdown := edReportMemoryLeaks.Checked;<br />end;<br /><br />procedure TForm1.FormCreate(Sender: TObject);<br />var<br /> //<br /> // loop variable<br /> //<br /> Index: Integer;<br />begin<br /> lbObjTypes.Items.BeginUpdate;<br /> try<br /> //<br /> // create instance of TSimpleEventList;<br /> //<br /> FSimpleEventList := TSimpleEventList.Create;<br /> //<br /> // this list will hold all instance, we don't want memory leaks!<br /> //<br /> FSimpleObjectList := TSimpleObjectList.Create;<br /> //<br /> // populate object list<br /> //<br /> for Index := Low(CSIMPLEOBJECTS) to High(CSIMPLEOBJECTS) do<br /> lbObjTypes.Items.AddObject(<br /> //<br /> // add class name for visual<br /> //<br /> CSIMPLEOBJECTS[Index].ClassName,<br /> //<br /> // hack to store the "index" of object type from CSIMPLEOBJECTS<br /> // WE DON'T ASSUME the Low and High bound!!!<br /> //<br /> TObject(Index)<br /> );<br /> //<br /> // initialize variable to zero<br /> //<br /> FUnreadLogs := 0;<br /> finally<br /> lbObjTypes.Items.EndUpdate;<br /> end; // tryf<br />end;<br /><br />procedure TForm1.FormDestroy(Sender: TObject);<br />begin<br /> //<br /> // free objects<br /> //<br /> FreeObjects;<br /> //<br /> // destroy instance of TSimpleEventList;<br /> //<br /> FSimpleEventList.Free;<br /> //<br /> // free objects holder<br /> //<br /> FSimpleObjectList.Free;<br />end;<br /><br />procedure TForm1.FreeObjects(const AtIndex: Integer);<br /><br /> procedure RemoveObject(const ObjIndex: Integer);<br /> var<br /> LSimpleObject: TSimpleObjectBase;<br /> LClassName: string;<br /> LAddress: string;<br /> begin<br /> LSimpleObject := FSimpleObjectList[ ObjIndex ];<br /> LClassName := LSimpleObject.ClassName;<br /> LAddress := GetAddrHex(LSimpleObject);<br /> //<br /> // remove event from event list<br /> //<br /> SimpleEventList.Delete(ObjIndex);<br /> //<br /> // log<br /> //<br /> Log('Removed event for instance of type %s @ 0x%s', [<br /> LClassName,<br /> LAddress<br /> ]);<br /> //<br /> // remove from list view<br /> //<br /> lvObjsCreated.Items.Delete(ObjIndex);<br /> //<br /> // free object<br /> //<br /> LSimpleObject.Free;<br /> //<br /> // log<br /> //<br /> Log('Instance of type %s @ 0x%s was freed', [<br /> LClassName,<br /> LAddress<br /> ]);<br /> //<br /> // remove object from list<br /> //<br /> FSimpleObjectList.Delete( ObjIndex );<br /> end; // procedure RemoveObject(const ObjIndex: Integer);<br /><br />var<br /> Index: Integer;<br />begin<br /> lvObjsCreated.Items.BeginUpdate;<br /> edLog.Lines.BeginUpdate;<br /> try<br /> if AtIndex >= 0 then<br /> RemoveObject(AtIndex)<br /> else<br /> for Index := FSimpleObjectList.Count -1 downto 0 do<br /> RemoveObject(Index);<br /> finally<br /> lvObjsCreated.Items.EndUpdate;<br /> edLog.Lines.EndUpdate;<br /> end; // tryf<br />end;<br /><br />function TForm1.GetAddrHex(AAddress: Pointer): string;<br />begin<br /> Result := IntToHex(Integer(AAddress), 8);<br />end;<br /><br />procedure TForm1.Log(const s: string);<br />begin<br /> edLog.Lines.Add(Format('[%s] %s', [DateTimeToStr(Now), s]));<br /> if pcLog.ActivePageIndex <> tsActivityLog.PageIndex then<br /> Inc(FUnreadLogs)<br /> else<br /> FUnreadLogs := 0;<br /> UpdateStatusbar;<br />end;<br /><br />procedure TForm1.Log(const fmt: string; const args: array of const);<br />begin<br /> Log(Format(fmt, args));<br />end;<br /><br />procedure TForm1.OnObjectMessage(Sender: TObject; AMessage: string);<br />begin<br /> edMsgObjs.Lines.Add(Format('[%s] %s called by %s', [<br /> DateTimeToStr(Now),<br /> Sender.ClassName,<br /> AMessage<br /> ]));<br />end;<br /><br />procedure TForm1.SelectObjTypes(ASelect: TObjTypeSelect);<br />var<br /> Index: Integer;<br />begin<br /> for Index := 0 to lbObjTypes.Count -1 do<br /> case ASelect of<br /> TObjTypeSelect.otsAll:<br /> lbObjTypes.Checked[ Index ] := True;<br /> TObjTypeSelect.otsInvert:<br /> lbObjTypes.Checked[ Index ] := NOT lbObjTypes.Checked[ Index ];<br /> TObjTypeSelect.otsNone:<br /> lbObjTypes.Checked[ Index ] := False;<br /> end; // case ASelect of<br />end;<br /><br />procedure TForm1.tsActivityLogShow(Sender: TObject);<br />begin<br /> FUnreadLogs := 0;<br /> UpdateStatusbar;<br />end;<br /><br />procedure TForm1.UpdateStatusbar;<br />begin<br /> sbMain.Panels[1].Text := IntToStr(SimpleEventList.Count);<br /> sbMain.Panels[3].Text := IntToStr(FUnreadLogs);<br /> sbMain.Panels[5].Text := IntToStr(TSimpleObjectBase.InstanceCount);<br />end;<br /><br />initialization<br /> //<br /> // set RandSeed<br /> //<br /> RandSeed := Ceil(Tomorrow / Today * Now);<br /> //<br /> // call Randomize<br /> //<br /> Randomize;<br /><br />end.<br /></textarea><br /></pre><div id="meham_download"><a href="https://sites.google.com/site/delphigeist/downloads/multiple_events_demo.zip">Click here to download the source code.</a></div>Well, that's about it for now, I hope you enjoy this demo!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-70535213867287072472012-02-18T13:45:00.000+02:002012-02-18T13:45:01.887+02:00tDCS -- say what?<b><i><u>WARNING</u></i></b>:<br /><b><span style="color: #990000;">You should NOT experiment with tDCS WITHOUT MEDICAL SUPERVISION, experiments with tDCS were and are made on perfectly healthy people, therefore if you have any health issues whatsoever(even allergies), please consider only informing yourself about this subject and NEVER, under any circumstances, try to experiment.</span></b><br /><br />Yesterday I've found out about <a href="http://en.wikipedia.org/wiki/Transcranial_direct-current_stimulation">tDCS </a>-- no, it's not a Delphi class, but there should be one! -- while reading <a href="http://gizmodo.com/tdcs/">this</a> article on <a href="http://gizmodo.com/">gizmodo.com</a><br /><br />Short Q&A:<br />Q: what does the name mean?<br />A: the longer version of the name is <b style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;">Transcranial Direct Current Stimulation</b><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;"><br /></span><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;">Q: is it dangerous?</span><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;">A: let's put it this way: if you don't read enough about it(both pros and cons) and you're not ready to take the risk of going loco, then, maybe you shouldn't hook a battery to your head.</span><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;"><br /></span><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;">Q: applications?</span><br /><span style="background-color: white; font-family: sans-serif; font-size: 13px; line-height: 20px;">A: some can be read <a href="http://clinicaltrials.gov/ct2/show/NCT01135953">here</a>, <a href="http://www.atlantapaindoctors.com/pain-relief/tdcs-transcranial-direct-current-stimulation/">here</a>, <a href="http://www.sciencedirect.com/science/article/pii/S1053811910014667">here</a>, <a href="http://en.wikipedia.org/wiki/Transcranial_direct-current_stimulation#cite_ref-Boggio_10-1">here </a>and of course <a href="http://www.google.ro/webhp?sourceid=chrome-instant&ix=seb&ie=UTF-8&ion=1#sclient=psy-ab&hl=ro&site=webhp&source=hp&q=tDCS%2Bapplications&pbx=1&oq=tDCS%2Bapplications&aq=f&aqi=g-vCL1&aql=&gs_sm=3&gs_upl=7087l17868l0l18031l15l15l0l0l0l0l121l1268l8.6l14l0&bav=on.2,or.r_gc.r_pw.r_cp.,cf.osb&fp=d3ea540a838bcfd9&ix=seb&ion=1&biw=948&bih=463http://www.google.ro/webhp?sourceid=chrome-instant&ix=seb&ie=UTF-8&ion=1#sclient=psy-ab&hl=ro&site=webhp&source=hp&q=tDCS%2Bapplications&pbx=1&oq=tDCS%2Bapplications&aq=f&aqi=g-vCL1&aql=&gs_sm=3&gs_upl=7087l17868l0l18031l15l15l0l0l0l0l121l1268l8.6l14l0&bav=on.2,or.r_gc.r_pw.r_cp.,cf.osb&fp=d3ea540a838bcfd9&ix=seb&ion=1&biw=948&bih=463">google</a></span><br /><br />In case you haven't checked the <a href="http://gizmodo.com/tdcs/">article </a>on gizmodo, here's an image illustrating the idea behind it(courtasy of <a href="http://gizmodo.com/">gizmodo.com</a>)<br /><div class="separator" style="clear: both; text-align: center;"><a href="http://cache.gawkerassets.com/assets/images/4/2012/02/9f563e74dcf75125f2a5a3097e11fdd5.jpg" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" height="180" src="http://cache.gawkerassets.com/assets/images/4/2012/02/9f563e74dcf75125f2a5a3097e11fdd5.jpg" width="320" /></a></div><div class="separator" style="clear: both; text-align: left;"><br /></div>The trouble with us currently, is that we don't have enough time these days to learn something new, tDCS could be a cheat that we can activate whenever we need, but we can't run around with a battery in our pocket or remember to charge it every day, because it can take some time to get used to and it can get pretty odd, so how can we cheat(yet again)?<br />It turns out that for quite a few years, there's a little device in our pocket or near us every day that we take special care of being charged, that's right! your mobile phone/tablet/laptop! but what do this three types of devices have in common? well, most of them have a mini <a href="http://en.wikipedia.org/wiki/Universal_Serial_Bus">usb</a>, so with two wires hooked to your brain and plugged into your favorite device's usb port, tadam! you got yourself a tDCS on the go.<br /><br />For the purpose of this article, I will choose an Android phone as a good device for experimenting, why? because it is very flexible, you can do a lot of weird stuff with it, after all, it is using a linux kernel...<br /><br />The Cocktail:<br />- one rooted(it may be possible to play with it without rooting, not sure) Android phone<br />- an app that let's you fiddle with the usb<br />- a mini usb cable<br />now that you have everything you need, I assume that the app is capable of managing the amount of current the usb port will serve <b><i><u><span style="color: #990000;">and that you have thought about this long enough</span></u></i></b>, you can start experimenting!<br /><br />Here are a couple of ideas:<br />- X second(s) on, X second(s) off<br />- X second(s) on, Y second(s) off<br />- take the rhythm of your favorite song, translate it into electrical impulses<br />- test your skills on something that puts your brain to work, first without tDCS and then with, but on different games/tests/etc.<br />- test all or part of the above using an EEG(i.e. <a href="http://emotiv.com/">http://emotiv.com/</a>, too expensive? then take a look at <a href="http://openeeg.sourceforge.net/doc/">this</a>) device<br />once you've started, I'm sure you can take experiments to a whole new level, next level, next level! (:<br /><br /><a href="http://wiki.freepascal.org/Custom_Drawn_Interface/Android">Since Free Pascal is capable of creating Android apps, maybe you should start there?</a><br /><br />I would love to read your ideas regarding this project.<br /><br />Was <a href="http://ro.wikipedia.org/wiki/Ray_Kurzweil">Ray Kurzweil</a> right about <a href="http://www.singularity.com/">singularity </a>being near? I believe so, what do you think?<br /><em style="background-color: white; color: #1122cc; cursor: pointer; font-family: arial, sans-serif; font-style: normal; font-weight: bold; white-space: nowrap;"><br /></em><br /><em style="background-color: white; color: #1122cc; cursor: pointer; font-family: arial, sans-serif; font-style: normal; font-weight: bold; white-space: nowrap;"><span style="color: black; font-family: 'Times New Roman'; font-weight: normal; white-space: normal;">Sometime within the next couple of days, I'll post something that is partially related to this, but much more significant in terms of applications and lower health risk.</span></em>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-91846997392078604892011-05-09T01:12:00.000+03:002011-05-09T01:12:41.388+03:00Boyer-Moore Horspool return all occurrences in one goFirst I would like to say that I'm sorry for not posting for quite some time now, but thanks to Simon H. who found a bug in original algorithm found <a href="http://www.delphigeist.com/2010/04/boyer-moore-horspool-in-delphi-2010.html">here</a>, I've managed to also extend the function to return all occurrences of a pattern in a string, without further introduction here's the code!<br /><pre>type<br /> TFSResults = array of Integer;<br /><br />function FindStringMulti(const Value, Pattern: string;<br /> const CaseSensitive: Boolean = True;<br /> const StartPos: Integer = 1): TFSResults;<br />var<br /> Index: Integer;<br /> jIndex: Integer;<br /> kIndex: Integer;<br /> LLenPattern: Integer;<br /> LLenValue: Integer;<br /> LSkipTable: array[Char] of Integer;<br /> LChar: Char;<br /><br /> function __SameChar: Boolean;<br /> begin<br /> if CaseSensitive then<br /> Result := (Value[Index] = Pattern[jIndex])<br /> else<br /> Result := (CompareText(Value[Index], Pattern[jIndex]) = 0);<br /> end; // function __SameChar: Boolean;<br /><br />begin<br /> LLenPattern := Length(Pattern);<br /> if LLenPattern = 0 then<br /> Exit;<br /> for LChar := Low(Char) to High(Char) do<br /> LSkipTable[LChar] := LLenPattern;<br /> if CaseSensitive then begin<br /> for kIndex := 1 to LLenPattern -1 do<br /> LSkipTable[Pattern[kIndex]] := LLenPattern -kIndex;<br /> end else begin<br /> for kIndex := 1 to LLenPattern -1 do<br /> LSkipTable[Windows.CharLower(@Pattern[kIndex])^] := LLenPattern -kIndex;<br /> end; // if CaseSensitive then begin<br /> kIndex := LLenPattern + (StartPos -1);<br /> LLenValue := Length(Value);<br /> while (kIndex <= LLenValue) do begin<br /> Index := kIndex;<br /> jIndex := LLenPattern;<br /> while (jIndex >= 1) do begin<br /> if __SameChar then begin<br /> jIndex := jIndex -1;<br /> Index := Index -1;<br /> end else<br /> jIndex := -1;<br /> if jIndex = 0 then begin<br /> SetLength(Result, Length(Result) +1);<br /> Result[High(Result)] := Index +1;<br /> jIndex := -1;<br /> end; // if jIndex = 0 then begin<br /> kIndex := kIndex + LSkipTable[Value[kIndex]];<br /> end; // while (jIndex >= 1) do begin<br /> end; // while (kIndex <= LLenValue) do begin<br />end;<br /></pre><br />Enjoy!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com5tag:blogger.com,1999:blog-7691723069373577907.post-46939755225326321052011-02-02T16:52:00.002+02:002011-02-02T16:56:29.230+02:00Breaking News: 1st November 2011 RAD Studio deal!Here's something that <b>leaked</B> from Embarcadero's future plans:<br /><blockquote>As of 1st November 2011 Embarcadero is proud to announce the release of Embarcadero RAD Studio XE Second Edition for as low as $100,— per year developer license. We will also include some new community based free services for registered customers, the services are: ednMigrate, ednBlogger, ednHelp.<br /><br />What is included in the Embarcadero RAD Studio XE Second Edition:<br />- Delphi XE SE<br />- C++ Builder XE SE<br />- Rad PHP XE SE<br />- Delphi Prism XE SE<br />- cross platform: Windows, Mac and Linux<br />- full source code for VCL, RTL<br />- over 200 demo applications to help you get started<br />- latest updates included in the license<br /><br />What is ednMigrate:<br />ednMigrate is a new community based service available for Embarcadero registered customers that will help you migrate your code from a earlier version of Delphi for example to the latest, you don't have to worry anymore about code compatibility.<br />You can access ednMigrate at http://ednmigrate.embarcadero.com/ and log in using your Embarcadero customer account.<br /><br />What is ednBlogger:<br />We know that you want to share your knowledge with other developers, therefore Embarcadero will host your blog free of charge(applicable for customers only) for any Embarcadero product.<br />You can access ednBlogger at http://ednblogger.embarcadero.com/ and log in using your Embarcadero customer account.<br /><br />What is ednHelp:<br />ednHelp is a new community based service available for Embarcadero registered customers that will host questions and answers related to application development, you can ask and answer as many questions as you like, the service is free of charge for all customers.<br />You can access ednHelp at http://ednhelp.embarcadero.com/ and log in using your Embarcadero customer account.<br /><br />We have done everything we could in order to provide you with best prices for independent developers, students, new companies and existing customers:<br />Here are our latest prices:<br /><table><TR><td>Target</TD><td>Price</TD></TR><tr> <td>Independent Developers</TD> <td>$200,—/year</TD> </TR><tr> <td>Students</TD> <td>$100,—/year</TD> </TR><tr> <td>New companies</TD> <td>$100,—/developer first year and $150,—/year starting from 2nd year</TD> </TR><tr> <td>Existing customers</TD> <td>$150,—/year</TD> </TR><tr> <td>Schools</TD> <td>$50,—/year</TD> </TR></TABLE>If you would like to do a test drive of any of our products before purchasing you can do so by navigating to http://testdrive.embarcadero.com/ select a product to download and don't forget that you can always write us a feedback at http://testdrive.embarcadero.com/feedback/ if you care to help us improve our services.<br /><br />Because Embarcadero truly cares about it's customers, as of 1st February 2012 we will hold conferences all around the world so that developers can have a taste of latest technologies or share their knowledge, this is also a good opportunity for new businesses to find partners or students and independent developers to find jobs.<br /></BLOCKQUOTE>OK, OK you got me, <b>it's NOT true</B>, unfortunately... but it would be nice if Embarcadero would do something similar not the "Starter edition" stuff... which I personally disagree with it, first because it comes without source code or debugger(ewww...) and second because the price is still pretty high for students for example.<br />Personal appeal to Embarcadero, let's support schools and students shall we guys?! in some schools in Romania the pascal language is STILL present, however I'm NOT sure if that will be true in 1 or 2 years from now, given the fact that Microsoft is doing a terrific job spreading it's software all around the world, I would NOT be surprised if they will have Visual Studio in most schools.<br /><br />And another thing, I get more than 60% of my blog hits from searches like "Delphi distiller", "Delphi XE distiller" and similar keywords, what does THAT mean to Embarcadero?! shit load of customers and money TOTALLY WASTED, is Embarcadero that rich?! probably...<br /><br />One more thing, before people will start criticise me, please DO NOT THINK that $140,— per start edition or whatever the price is or will be is NOT a lot of money, you don't take into account countries that have thousands of Delphi developers which earn ~$500,—/month or less, so yes $140,— might not be a lot for US or European citizens but for other parts of the world it is.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com5tag:blogger.com,1999:blog-7691723069373577907.post-66809367883491705782011-02-01T07:44:00.001+02:002011-02-01T07:45:03.841+02:00Laptop specific functionsFirst I would like to thank each and every one of the developers from <a href="http://www.stackoverflow.com">stackoverflow</a> who helped me out in detecting if application is running on laptop by answering <a href="http://stackoverflow.com/questions/4849447/detect-if-application-is-running-on-laptop">my question</a>.<br />I have pushed the envelop further by defining some helper functions which retrieves laptop specific information and some other as well, so without further introduction here's the unit that I've wrote, feel free to use it in commercial and/or personal applications <b>AT YOUR OWN RISK</B> of course, also if you find some flaws(high probability -- haven't tested enough) please feel free to drop a comment.<br /><pre>unit uDGMobileUtils;<br /><br />interface<br /><br />(*******************************************************************************<br /><br /> Author:<br /> Dorin Duminica<br /><br /> Note:<br /> That Parts of the code are Copyright© of Microsoft Corporation.<br /> All Rights Reserved.<br /><br /> Disclaimer:<br /> Using the following code represents your acknowledgement that YOU TAKE<br /> FULL RESPONSABILITY of any damage it can and/or might cause to your<br /> system, country, pets, etc.<br /><br /> Requirements:<br /> According to Microsoft the following code should work starting from<br /> Windows 2000 Professional and Server<br /><br />*******************************************************************************)<br /><br />uses<br /> Windows;<br /><br />{$Z4} // required in order to have 4 byte enumerated type<br /><br />type<br /> SYSTEM_POWER_STATE =(<br /> PowerSystemUnspecified,<br /> PowerSystemWorking,<br /> PowerSystemSleeping1,<br /> PowerSystemSleeping2,<br /> PowerSystemSleeping3,<br /> PowerSystemHibernate,<br /> PowerSystemShutdown,<br /> PowerSystemMaximum);<br /><br />{$Z1} // restore enumerated type to 1 byte<br /><br />const<br /> SYSTEM_POWER_STATE_NAMES: array[SYSTEM_POWER_STATE] of string = (<br /> 'Unspecified',<br /> 'Working',<br /> 'Sleeping 1',<br /> 'Sleeping 2',<br /> 'Sleeping 3',<br /> 'Hibernate',<br /> 'Shutdown',<br /> 'Maximum');<br /><br />type<br /> BATTERY_REPORTING_SCALE = record<br /> Granularity: ULONG;<br /> Capacity: ULONG;<br /> end;<br /><br /> PBATTERY_REPORTING_SCALE = ^BATTERY_REPORTING_SCALE;<br /><br />type<br /> SYSTEM_POWER_CAPABILITIES = record<br /> // If this member is TRUE, there is a system power button.<br /> PowerButtonPresent: Boolean;<br /> // If this member is TRUE, there is a system sleep button.<br /> SleepButtonPresent: Boolean;<br /> // If this member is TRUE, there is a lid switch.<br /> LidPresent: Boolean;<br /> // for S1 —> S5 check microsoft site<br /> SystemS1: Boolean;<br /> SystemS2: Boolean;<br /> SystemS3: Boolean;<br /> SystemS4: Boolean;<br /> SystemS5: Boolean;<br /> // If this member is TRUE, the operating system supports power off state S5 (soft off).<br /> HiberFilePresent: Boolean;<br /> // If this member is TRUE, the system supports wake capabilities.<br /> FullWake: Boolean;<br /> // If this member is TRUE, the system supports video display dimming capabilities.<br /> VideoDimPresent: Boolean;<br /> // If this member is TRUE, the system supports APM BIOS power management features.<br /> ApmPresent: Boolean;<br /> // If this member is TRUE, there is an uninterruptible power supply (UPS).<br /> UpsPresent: Boolean;<br /> // If this member is TRUE, the system supports thermal zones.<br /> ThermalControl: Boolean;<br /> // If this member is TRUE, the system supports processor throttling.<br /> ProcessorThrottle: Boolean;<br /> // The minimum level of system processor throttling supported,<br /> // expressed as a percentage.<br /> ProcessorMinThrottle: UCHAR;<br /> // The maximum level of system processor throttling supported,<br /> // expressed as a percentage.<br /> ProcessorMaxThrottle: UCHAR;<br /> // If this member is TRUE, the system supports the hybrid sleep state.<br /> // Windows Server 2003 and Windows XP: Hybrid sleep is not supported.<br /> // Windows 2000: This member is not supported.<br /> FastSystemS4: Boolean;<br /> // reserved<br /> spare2: array [0 .. 3] of UCHAR;<br /> // If this member is TRUE, the system supports allowing the removal of power<br /> // to fixed disk devices.<br /> DiskSpinDown: Boolean;<br /> // reserved<br /> spare3: array [0 .. 7] of UCHAR;<br /> // If this member is TRUE, there are one or more batteries in the system.<br /> SystemBatteriesPresent: Boolean;<br /> // If this member is TRUE, the system batteries are short-term.<br /> // Short-term batteries are used in uninterruptible power supplies (UPS).<br /> BatteriesAreShortTerm: Boolean;<br /> // A BATTERY_REPORTING_SCALE structure that contains information about<br /> // how system battery metrics are reported.<br /> BatteryScale: array [0 .. 2] of BATTERY_REPORTING_SCALE;<br /> // The lowest system sleep state (Sx) that will generate a wake event when<br /> // the system is on AC power. This member must be one of the<br /> // SYSTEM_POWER_STATE enumeration type values.<br /> AcOnLineWake: SYSTEM_POWER_STATE;<br /> // The lowest system sleep state (Sx) that will generate a wake event via<br /> // the lid switch. This member must be one of the SYSTEM_POWER_STATE<br /> // enumeration type values.<br /> SoftLidWake: SYSTEM_POWER_STATE;<br /> // To wake the computer using the RTC, the operating system must also<br /> // support waking from the sleep state the computer is in when the RTC<br /> // generates the wake event. Therefore, the effective lowest sleep state<br /> // from which an RTC wake event can wake the computer is the lowest sleep<br /> // state supported by the operating system that is equal to or higher than<br /> // the value of RtcWake. To determine the sleep states that the operating<br /> // system supports, check the SystemS1, SystemS2, SystemS3, and SystemS4 members.<br /> RtcWake: SYSTEM_POWER_STATE;<br /> // The minimum allowable system power state supporting wake events.<br /> // This member must be one of the SYSTEM_POWER_STATE enumeration type values.<br /> // Note that this state may change as different device drivers are<br /> // installed on the system.<br /> MinDeviceWakeState: SYSTEM_POWER_STATE;<br /> // The default system power state used if an application calls<br /> // RequestWakeupLatency with LT_LOWEST_LATENCY. This member must be one of<br /> // the SYSTEM_POWER_STATE enumeration type values.<br /> DefaultLowLatencyWake: SYSTEM_POWER_STATE;<br /> end;<br /><br /> PSYSTEM_POWER_CAPABILITIES = ^SYSTEM_POWER_CAPABILITIES;<br /><br />type<br /> TACLineStatus = (<br /> // battery<br /> acsOffline = 0,<br /> // plugged in<br /> acsOnline = 1,<br /> acsUnknown = 255);<br /><br />type<br /> TBatteryState = (<br /> // High—the battery capacity is at more than 66 percent<br /> bsHigh = 1,<br /> // Low—the battery capacity is at less than 33 percent<br /> bsLow = 2,<br /> // Critical—the battery capacity is at less than five percent<br /> bsCritical = 4,<br /> bsCharging = 8,<br /> bsNoSystemBattery = 128,<br /> // Unknown status—unable to read the battery flag information<br /> bsUnknown = 255);<br /><br /> TBatteryStatus = set of TBatteryState;<br /><br /> function GetPwrCapabilities(lpSystemPowerCapabilities: PSYSTEM_POWER_CAPABILITIES): Boolean; stdcall;<br /> function IsAdminOverrideActive: Boolean; stdcall;<br /> function IsPwrHibernateAllowed: Boolean; stdcall;<br /> function IsPwrShutdownAllowed: Boolean; stdcall;<br /> function IsPwrSuspendAllowed: Boolean; stdcall;<br /><br /> // utility<br /> function IsLidPresent: Boolean;<br /> function IsRunningMobile: Boolean;<br /> function IsRunningOnBattery: Boolean;<br /> function IsPowerBtnPresent: Boolean;<br /> function IsApmPresent: Boolean;<br /> function IsUpsPresent: Boolean;<br /> function IsThermalControl: Boolean;<br /> function GetACLineStatus: TACLineStatus;<br /> function GetACLineStatusName(const AACLineStatus: TACLineStatus): string;<br /> function GetBatteryStatus: TBatteryStatus;<br /> function GetBatteryStateName(const ABatteryState: TBatteryState): string;<br /> function GetBatteryStatusStr(const ABatteryState: TBatteryStatus;<br /> const ADelimiter: Char = ','): string;<br /> function GetBatteryLifePercent: Byte;<br /> function GetBatteryLifeTime: DWORD;<br /> function GetBatteryLifeTimeFull: DWORD;<br /> function GetNumberOfProcessors: DWORD;<br /> function GetSystemPowerStateName(const ASystemPowerState: SYSTEM_POWER_STATE): string;<br /><br />implementation<br /><br />uses<br /> SysUtils,<br /> Classes;<br /><br />const<br /> powrproflib = 'powrprof.dll';<br /><br />function GetPwrCapabilities(lpSystemPowerCapabilities: PSYSTEM_POWER_CAPABILITIES): Boolean; external powrproflib name 'GetPwrCapabilities';<br />function IsAdminOverrideActive: Boolean; external powrproflib name 'IsAdminOverrideActive';<br />function IsPwrHibernateAllowed: Boolean; external powrproflib name 'IsPwrHibernateAllowed';<br />function IsPwrShutdownAllowed: Boolean; external powrproflib name 'IsPwrShutdownAllowed';<br />function IsPwrSuspendAllowed: Boolean; external powrproflib name 'IsPwrSuspendAllowed';<br /><br />function IsLidPresent: Boolean;<br />var<br /> LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;<br />begin<br /> Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);<br /> if Result then<br /> Result := LSYSTEM_POWER_CAPABILITIES.LidPresent;<br />end;<br /><br />function IsRunningMobile: Boolean;<br />begin<br /> Result := IsLidPresent or IsRunningOnBattery;<br />end;<br /><br />function IsRunningOnBattery: Boolean;<br />begin<br /> Result := (GetACLineStatus = acsOffline);<br />end;<br /><br />function IsPowerBtnPresent: Boolean;<br />var<br /> LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;<br />begin<br /> Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);<br /> if Result then<br /> Result := LSYSTEM_POWER_CAPABILITIES.PowerButtonPresent;<br />end;<br /><br />function IsApmPresent: Boolean;<br />var<br /> LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;<br />begin<br /> Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);<br /> if Result then<br /> Result := LSYSTEM_POWER_CAPABILITIES.ApmPresent;<br />end;<br /><br />function IsUpsPresent: Boolean;<br />var<br /> LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;<br />begin<br /> Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);<br /> if Result then<br /> Result := LSYSTEM_POWER_CAPABILITIES.UpsPresent;<br />end;<br /><br />function IsThermalControl: Boolean;<br />var<br /> LSYSTEM_POWER_CAPABILITIES: SYSTEM_POWER_CAPABILITIES;<br />begin<br /> Result := GetPwrCapabilities(@LSYSTEM_POWER_CAPABILITIES);<br /> if Result then<br /> Result := LSYSTEM_POWER_CAPABILITIES.ThermalControl;<br />end;<br /><br />function GetACLineStatus: TACLineStatus;<br />var<br /> LSystemPowerStatus: TSystemPowerStatus;<br />begin<br /> Result := acsUnknown;<br /> if GetSystemPowerStatus(LSystemPowerStatus) then<br /> Result := TACLineStatus(LSystemPowerStatus.ACLineStatus);<br />end;<br /><br />function GetACLineStatusName(const AACLineStatus: TACLineStatus): string;<br />begin<br /> Result := 'Unknown';<br /> case AACLineStatus of<br /> acsOffline: Result := 'Offline';<br /> acsOnline: Result := 'Online';<br /> end; // case AACLineStatus of<br />end;<br /><br />function GetBatteryStatus: TBatteryStatus;<br />var<br /> LSystemPowerStatus: TSystemPowerStatus;<br /><br /> procedure CheckState(const ABatteryState: TBatteryState);<br /> begin<br /> if (LSystemPowerStatus.BatteryFlag and Ord(ABatteryState)) = Ord(ABatteryState) then<br /> Include(Result, ABatteryState);<br /> end; // procedure CheckState(const ABatteryState: TBatteryState);<br /><br />begin<br /> Result := [];<br /> if GetSystemPowerStatus(LSystemPowerStatus) then begin<br /> CheckState(bsHigh);<br /> CheckState(bsLow);<br /> CheckState(bsCritical);<br /> CheckState(bsCharging);<br /> CheckState(bsNoSystemBattery);<br /> CheckState(bsUnknown);<br /> end else<br /> Result := [bsUnknown];<br />end;<br /><br />function GetBatteryStateName(const ABatteryState: TBatteryState): string;<br />begin<br /> case ABatteryState of<br /> bsHigh: Result := 'High';<br /> bsLow: Result := 'Low';<br /> bsCritical: Result := 'Critical';<br /> bsCharging: Result := 'Charging';<br /> bsNoSystemBattery: Result := 'No system battery';<br /> bsUnknown: Result := 'Unknown';<br /> end; // case ABatteryState of<br />end;<br /><br />function GetBatteryStatusStr(const ABatteryState: TBatteryStatus;<br /> const ADelimiter: Char): string;<br />var<br /> LBatteryState: TBatteryState;<br /> LNames: TStringList;<br />begin<br /> Result := EmptyStr;<br /> LNames := TStringList.Create;<br /> try<br /> LNames.Delimiter := ADelimiter;<br /> for LBatteryState in ABatteryState do<br /> LNames.Add(GetBatteryStateName(LBatteryState));<br /> Result := LNames.DelimitedText;<br /> finally<br /> FreeAndNil(LNames);<br /> end; // tryf<br />end;<br /><br />function GetBatteryLifePercent: Byte;<br />var<br /> LSystemPowerStatus: TSystemPowerStatus;<br />begin<br /> Result := 0;<br /> if GetSystemPowerStatus(LSystemPowerStatus) then<br /> // The percentage of full battery charge remaining.<br /> // This value in the range 0 to 100 or 255 if status is unknown.<br /> Result := LSystemPowerStatus.BatteryLifePercent;<br />end;<br /><br />function GetBatteryLifeTime: DWORD;<br />var<br /> LSystemPowerStatus: TSystemPowerStatus;<br />begin<br /> Result := DWORD(-1);<br /> if GetSystemPowerStatus(LSystemPowerStatus) then<br /> // The number of seconds of battery life remaining,<br /> // or –1 if remaining seconds are unknown.<br /> Result := LSystemPowerStatus.BatteryLifeTime;<br />end;<br /><br />function GetBatteryLifeTimeFull: DWORD;<br />var<br /> LSystemPowerStatus: TSystemPowerStatus;<br />begin<br /> Result := DWORD(-1);<br /> if GetSystemPowerStatus(LSystemPowerStatus) then<br /> // The number of seconds of battery life when at full charge,<br /> // or –1 if full battery lifetime is unknown.<br /> Result := LSystemPowerStatus.BatteryFullLifeTime;<br />end;<br /><br />function GetNumberOfProcessors: DWORD;<br />var<br /> LSystemInfo: TSystemInfo;<br />begin<br /> GetSystemInfo(LSystemInfo);<br /> // number of processor means number of threads<br /> // i.e. a processor with 4 cores can have 8 threads<br /> Result := LSystemInfo.dwNumberOfProcessors;<br />end;<br /><br />function GetSystemPowerStateName(const ASystemPowerState: SYSTEM_POWER_STATE): string;<br />begin<br /> Result := SYSTEM_POWER_STATE_NAMES[ASystemPowerState];<br />end;<br /><br />end.<br /></PRE>How to use it:<br />a) drop a memo and a button on the form, rename the memo to "edInfo"<br />b) double-click the button and copy-paste the following code<br /><pre>procedure TForm1.Button1Click(Sender: TObject);<br /><br /> procedure AddBool(const s: string; const Value: Boolean);<br /> begin<br /> edInfo.Lines.Add(Format('%s = %s', [s, BoolToStr(Value, True)]));<br /> end; // procedure AddBool(const s: string; const Value: Boolean);<br /><br /> procedure AddString(const s, Value: string);<br /> begin<br /> edInfo.Lines.Add(Format('%s = %s', [s, Value]));<br /> end; // procedure AddString(const s, Value: string);<br /><br /> procedure AddPercent(const s: string; const Value: Byte);<br /> begin<br /> edInfo.Lines.Add(Format('%s = %d%%', [s, Value]));<br /> end; // procedure AddPercent(const s: string; const Value: Byte);<br /><br /> procedure AddSeconds(const s: string; const Value: DWORD);<br /> begin<br /> edInfo.Lines.Add(Format('%s = %d sec.', [s, Value]));<br /> end; // procedure AddSeconds(const s: string; const Value: DWORD);<br /><br /> procedure AddDWord(const s: string; const Value: DWORD);<br /> begin<br /> edInfo.Lines.Add(Format('%s = %d', [s, Value]));<br /> end; // procedure AddDWord(const s: string; const Value: DWORD);<br /><br />begin<br /> edInfo.Clear;<br /> AddBool('IsLidPresent', IsLidPresent);<br /> AddBool('IsRunningMobile', IsRunningMobile);<br /> AddBool('IsRunningOnBattery', IsRunningOnBattery);<br /> AddBool('IsPowerBtnPresent', IsPowerBtnPresent);<br /> AddBool('IsApmPresent', IsApmPresent);<br /> AddBool('IsUpsPresent', IsUpsPresent);<br /> AddBool('IsThermalControl', IsThermalControl);<br /> AddString('GetACLineStatus', GetACLineStatusName(GetACLineStatus));<br /> AddString('GetBatteryStatusStr', GetBatteryStatusStr(GetBatteryStatus));<br /> AddPercent('GetBatteryLifePercent', GetBatteryLifePercent);<br /> // if GetBatteryLifeTime = -1 it means that laptop is either plugged in OR<br /> // it is running on battery for a few seconds -- Windows did NOT detect<br /> // yet or it can't tell for certain how many seconds left<br /> // also the value might increase in a couple of seconds<br /> AddSeconds('GetBatteryLifeTime', GetBatteryLifeTime);<br /> // in my tests GetBatteryLifeTimeFull retrieves only -1 it might have something<br /> // to do with the fact that my laptop is only a couple of days old<br /> // or something fails -- I'm NOT 100% sure on this, please feel free to comment<br /> AddSeconds('GetBatteryLifeTimeFull', GetBatteryLifeTimeFull);<br /> AddDWord('GetNumberOfProcessors', GetNumberOfProcessors);<br />end;<br /></PRE>c) and last but not least HAVE FUN!!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-9293136672609102672011-01-26T09:16:00.001+02:002011-01-26T09:35:26.485+02:00Fun with DWM<a HREF="https://sites.google.com/site/delphigeist/screenshots/dwm_demo1.png"><img SRC="https://sites.google.com/site/delphigeist/screenshots/dwm_demo1.png"></A><br />Sooo... you like the "Peak preview" of Windows 7?! If so, then I bet you would want to play with it in your Delphi application, correct?! cool! here's how you do it in a few steps:<br /><br />a) create a new VCL forms application;<br />b) add Dwmapi to uses clause;<br />c) copy and paste and paste from the following code;<br /><br /><pre>unit Unit1;<br /><br />interface<br /><br />uses<br /> Windows,<br /> Messages,<br /> SysUtils,<br /> Variants,<br /> Classes,<br /> Graphics,<br /> Controls,<br /> Forms,<br /> Dialogs,<br /> Dwmapi,<br /> StdCtrls,<br /> ExtCtrls,<br /> Generics.Collections;<br /><br />type<br /> TDGWindow = record<br /> StrCaption: string;<br /> StrClassName: string;<br /> Handle: HWND;<br /> end;<br /><br /> TDGWindowList = class(TList<tdgwindow>);<br /><br />type<br /> TfrmMain = class(TForm)<br /> Panel1: TPanel;<br /> lbWindows: TListBox;<br /> bnRefresh: TButton;<br /> bnPreview: TButton;<br /> procedure FormDestroy(Sender: TObject);<br /> procedure bnRefreshClick(Sender: TObject);<br /> procedure bnPreviewClick(Sender: TObject);<br /> procedure lbWindowsDblClick(Sender: TObject);<br /> procedure FormCreate(Sender: TObject);<br /> private<br /> FWindowList: TDGWindowList;<br /> FTumbnail: HTHUMBNAIL;<br /> FPreviewEnabled: Boolean;<br /> private<br /> procedure PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);<br /> procedure PreviewDisable;<br /> public<br /> { Public declarations }<br /> end;<br /><br />var<br /> frmMain: TfrmMain;<br /><br />implementation<br /><br />{$R *.dfm}<br /><br />function FindWindowExtd(partialTitle: string): HWND;<br />var<br /> hWndTemp: hWnd;<br /> iLenText: Integer;<br /> cTitletemp: array [0..254] of Char;<br /> sTitleTemp: string;<br />begin<br /> hWndTemp := FindWindow(nil, nil);<br /> while hWndTemp <> 0 do begin<br /> iLenText := GetWindowText(hWndTemp, cTitletemp, 255);<br /> sTitleTemp := cTitletemp;<br /> sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));<br /> partialTitle := UpperCase(partialTitle);<br /> if pos( partialTitle, sTitleTemp ) <> 0 then<br /> Break;<br /> hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);<br /> end;<br /> result := hWndTemp;<br />end;<br /><br />procedure TfrmMain.bnPreviewClick(Sender: TObject);<br />var<br /> Index: Integer;<br /> LRect: TRect;<br />begin<br /> Index := lbWindows.ItemIndex;<br /> if Index < 0 then<br /> Exit;<br /> LRect := Rect(5, 5,<br /> Self.Width -Panel1.Width -20,<br /> Self.Height -10);<br /> PreviewWindow(<br /> FWindowList[Index].Handle,<br /> Self.Handle,<br /> LRect);<br />end;<br /><br />procedure TfrmMain.bnRefreshClick(Sender: TObject);<br />var<br /> LHDesktop: HWND;<br /> LHWindow: HWND;<br /> LHParent: HWND;<br /> LExStyle: DWORD;<br /> LBuffer: array[0..255] of char;<br /> LWindow: TDGWindow;<br />begin<br /> lbWindows.Items.BeginUpdate;<br /> lbWindows.Items.Clear;<br /> FWindowList.Clear;<br /> LHDesktop := GetDeskTopWindow;<br /> LHWindow := GetWindow(LHDesktop, GW_CHILD);<br /> while LHWindow <> 0 do begin<br /> LWindow.Handle := LHWindow;<br /> GetWindowText(LHWindow, LBuffer, Length(LBuffer));<br /> LHParent := GetWindowLong(LHWindow, GWL_HWNDPARENT);<br /> LExStyle := GetWindowLong(LHWindow, GWL_EXSTYLE);<br /> if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and<br /> ((LHParent = 0) or (LHParent = LHDesktop)) and<br /> ((LExStyle and WS_EX_TOOLWINDOW = 0) or (LExStyle and WS_EX_APPWINDOW <> 0))<br /> then begin<br /> lbWindows.Items.Add(LBuffer);<br /> LWindow.StrCaption := LBuffer;<br /> GetClassName(LHWindow, LBuffer, Length(LBuffer));<br /> LWindow.StrClassName := LBuffer;<br /> FWindowList.Add(LWindow);<br /> end; // if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and ...<br /> LHWindow := GetWindow(LHWindow, GW_HWNDNEXT);<br /> end; // while LHWindow <> 0 do begin<br /> lbWindows.Items.EndUpdate;<br /> if lbWindows.Items.Count > 0 then<br /> lbWindows.ItemIndex := 0;<br />end;<br /><br />procedure TfrmMain.FormCreate(Sender: TObject);<br />begin<br /> FPreviewEnabled := False;<br /> FWindowList := TDGWindowList.Create;<br />end;<br /><br />procedure TfrmMain.FormDestroy(Sender: TObject);<br />begin<br /> FWindowList.Clear;<br /> FreeAndNil(FWindowList);<br /> PreviewDisable;<br />end;<br /><br />procedure TfrmMain.lbWindowsDblClick(Sender: TObject);<br />begin<br /> bnPreview.Click;<br />end;<br /><br />procedure TfrmMain.PreviewDisable;<br />begin<br /> if FPreviewEnabled then<br /> FPreviewEnabled := NOT Succeeded(DwmUnregisterThumbnail(FTumbnail));<br />end;<br /><br />procedure TfrmMain.PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);<br />var<br /> LResult: HRESULT;<br /> LThumpProp: DWM_THUMBNAIL_PROPERTIES;<br />begin<br /> if NOT DwmCompositionEnabled then begin<br /> MessageDlg('DWM composition is NOT enabled.', mtWarning, [mbOK], 0);<br /> Exit;<br /> end; // if NOT DwmCompositionEnabled then begin<br /> PreviewDisable;<br /> FPreviewEnabled := Succeeded(DwmRegisterThumbnail(ADest, ASource, @FTumbnail));<br /> if FPreviewEnabled then begin<br /> LThumpProp.dwFlags := DWM_TNP_SOURCECLIENTAREAONLY or DWM_TNP_VISIBLE or<br /> DWM_TNP_OPACITY or DWM_TNP_RECTDESTINATION;<br /> LThumpProp.fSourceClientAreaOnly := False;<br /> LThumpProp.fVisible := True;<br /> LThumpProp.opacity := 200;<br /> LThumpProp.rcDestination := ARect;<br /> LResult := DwmUpdateThumbnailProperties(FTumbnail, LThumpProp);<br /> FPreviewEnabled := (LResult = S_OK);<br /> end else<br /> MessageDlg('Cannot link to window ' + IntToStr(ASource), mtError, [mbOK], 0);<br />end;<br /><br />end.<br /></PRE><a href="https://sites.google.com/site/delphigeist/downloads/dwm_test1.zip">or you simply download the demo application</a>.<br />d) have fun!!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-29584448582185946342011-01-15T11:10:00.000+02:002011-01-15T11:10:01.281+02:00uDGVMUtils version 1.1 thanks to Chee MengThanks to Chee Meng I've added a detection scheme for Virtual Box.<br />Please let me know of any scenario in which a function fails to return properly so that I can modify the code.<br /><PRE>unit uDGVMUtils;<br /><br />interface<br /><br />(*******************************************************************************<br /><br /> uDGVMUtils -- is an attempt to create one of the best virtual machine<br /> detector methods, feel free to contribute in any way you wish.<br /><br /> Version 1.1, 2010-01-15<br /><br /> Copyright© you are free to use it for comercial, private or both purposes<br /><br /> Contributors:<br /> Dorin Duminica<br /> Chee Meng<br /><br />*******************************************************************************)<br /><br />type<br /> TVMWareVersion = (<br /> vvExpress = 1,<br /> vvESX,<br /> vvGSX,<br /> vvWorkstation,<br /> vvUnknown,<br /> vvNative);<br /><br />const<br /> VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (<br /> 'Express',<br /> 'ESX',<br /> 'GSX',<br /> 'Workstation',<br /> 'Unknown',<br /> 'Native');<br /><br />type<br /> TVirtualMachineType = (<br /> vmNative,<br /> vmVMWare,<br /> vmWine,<br /> vmVirtualPC,<br /> vmVirtualBox);<br /><br />const<br /> VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (<br /> 'Native',<br /> 'VMWare',<br /> 'Wine',<br /> 'Virtual PC',<br /> 'Virtual Box');<br /><br />function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;<br />function IsRunningVMWare: Boolean; overload;<br />function IsRunningWine(var AWineVersion: string): Boolean; overload;<br />function IsRunningWine: Boolean; overload;<br />function IsRunningVirtualPC: Boolean;<br />function IsRunningVBox: Boolean;<br />function IsRunningVM(var AVMVersion: string): Boolean; overload;<br />function IsRunningVM: Boolean; overload;<br /><br />implementation<br /><br />uses<br /> SysUtils,<br /> Windows;<br /><br />function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;<br />const<br /> CVMWARE_FLAG = $564D5868;<br />var<br /> LFlag: Cardinal;<br /> LVersion: Cardinal;<br />begin<br /> LFlag := 0;<br /> try<br /> asm<br /> push eax<br /> push ebx<br /> push ecx<br /> push edx<br /><br /> mov eax, 'VMXh'<br /> mov ecx, 0Ah<br /> mov dx, 'VX'<br /><br /> in eax, dx<br /><br /> mov LFlag, ebx<br /> mov LVersion, ecx<br /><br /> pop edx<br /> pop ecx<br /> pop ebx<br /> pop eax<br /> end;<br /> except<br />// uncomment next two lines if you wish to see exception<br />// on E: Exception do<br />// ShowMessage(E.message);<br /> end; // trye<br /> if LFlag = CVMWARE_FLAG then begin<br /> Result := True;<br /> case LVersion of<br /> 1: AVMWareVersion := vvExpress;<br /> 2: AVMWareVersion := vvESX;<br /> 3: AVMWareVersion := vvGSX;<br /> 4: AVMWareVersion := vvWorkstation;<br /> else<br /> AVMWareVersion := vvUnknown;<br /> end<br /> end else begin<br /> Result := False;<br /> AVMWareVersion := vvNative;<br /> end; // if LFlag = CVMWARE_FLAG then begin<br />end;<br /><br />function IsRunningVMWare: Boolean;<br />var<br /> LVMWareVersion: TVMWareVersion;<br />begin<br /> Result := IsRunningVMWare(LVMWareVersion);<br />end;<br /><br />function IsRunningWine(var AWineVersion: string): Boolean;<br />type<br /> TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}<br /> TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}<br />var<br /> LHandle: THandle;<br /> LWineGetVersion: TWineGetVersion;<br /> LWineNTToUnixFileName: TWineNTToUnixFileName;<br />begin<br /> Result := False;<br /> AWineVersion := 'Unknown';<br /> LHandle := LoadLibrary('ntdll.dll');<br /> if LHandle > 32 then begin<br /> LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');<br /> LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');<br /> if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin<br /> Result := True;<br /> if Assigned(LWineGetVersion) then<br /> AWineVersion := StrPas(LWineGetVersion);<br /> end; // if Assigned(LWineGetVersion) or ...<br /> FreeLibrary(LHandle);<br /> end; // if LHandle > 32 then begin<br />end;<br /><br />function IsRunningWine: Boolean;<br />var<br /> LWineVersion: string;<br />begin<br /> Result := IsRunningWine(LWineVersion);<br />end;<br /><br />function IsRunningVirtualPC: Boolean;<br />asm<br /> push ebp;<br /> mov ebp, esp;<br /><br /> mov ecx, offset @exception_handler;<br /><br /> push ebx;<br /> push ecx;<br /><br /> push dword ptr fs:[0];<br /> mov dword ptr fs:[0], esp;<br /><br /> mov ebx, 0; // Flag<br /> mov eax, 1; // VPC function number<br /><br /> // call VPC<br /> db $0F, $3F, $07, $0B<br /><br /> mov eax, dword ptr ss:[esp];<br /> mov dword ptr fs:[0], eax;<br /><br /> add esp, 8;<br /><br /> test ebx, ebx;<br /><br /> setz al;<br /><br /> lea esp, dword ptr ss:[ebp-4];<br /> mov ebx, dword ptr ss:[esp];<br /> mov ebp, dword ptr ss:[esp+4];<br /><br /> add esp, 8;<br /><br /> jmp @ret1;<br /><br /> @exception_handler:<br /> mov ecx, [esp+0Ch];<br /> mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running<br /> add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC<br /> xor eax, eax; // exception is handled<br /><br /> @ret1:<br />end;<br /><br />function IsRunningVBox: Boolean;<br /><br /> function Test1: Boolean;<br /> var<br /> LHandle: Cardinal;<br /> begin<br /> Result := False;<br /> try<br /> LHandle := LoadLibrary('VBoxHook.dll');<br /> Result := (LHandle <> 0);<br /> if Result then<br /> FreeLibrary(LHandle);<br /> except<br /> end; // trye<br /> end; // function Test1: Boolean;<br /><br /> function Test2: Boolean;<br /> var<br /> LHandle: Cardinal;<br /> begin<br /> Result := False;<br /> try<br /> LHandle := CreateFile(<br /> '\\\\.\\\VBoxMiniRdrDN',<br /> GENERIC_READ,<br /> FILE_SHARE_READ,<br /> NIL,<br /> OPEN_EXISTING,<br /> FILE_ATTRIBUTE_NORMAL,<br /> 0);<br /> Result := (LHandle <> INVALID_HANDLE_VALUE);<br /> if Result then<br /> CloseHandle(LHandle);<br /> except<br /> end; // trye<br /> end; // function Test2: Boolean;<br /><br />begin<br /> Result := Test1 or Test2;<br />end;<br /><br />function IsRunningVM(var AVMVersion: string): Boolean;<br />begin<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];<br /> Result := True;<br /> if IsRunningWine then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]<br /> else<br /> if IsRunningVMWare then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]<br /> else<br /> if IsRunningVirtualPC then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]<br /> else<br /> if IsRunningVBox then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualBox]<br /> else begin<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];<br /> Result := False;<br /> end;<br />end;<br /><br />function IsRunningVM: Boolean;<br />var<br /> LVMVersion: string;<br />begin<br /> Result := IsRunningVM(LVMVersion);<br />end;<br /><br />end.<br /></PRE><FONT SIZE=3>HAVE FUN</FONT>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com2tag:blogger.com,1999:blog-7691723069373577907.post-57835628726597000962011-01-12T15:01:00.001+02:002011-01-12T22:48:51.937+02:00Is your app running in a virtual machine?Here's an extremely simple unit that will check if your application is running under VMWare, Wine and or Virtual PC:<br /><pre>unit uDGVMUtils;<br /><br />interface<br /><br />type<br /> TVMWareVersion = (<br /> vvExpress = 1,<br /> vvESX,<br /> vvGSX,<br /> vvWorkstation,<br /> vvUnknown,<br /> vvNative);<br /><br />const<br /> VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (<br /> 'Express',<br /> 'ESX',<br /> 'GSX',<br /> 'Workstation',<br /> 'Unknown',<br /> 'Native');<br /><br />type<br /> TVirtualMachineType = (<br /> vmNative,<br /> vmVMWare,<br /> vmWine,<br /> vmVirtualPC);<br /><br />const<br /> VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (<br /> 'Native',<br /> 'VMWare',<br /> 'Wine',<br /> 'Virtual PC');<br /><br />function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;<br />function IsRunningVMWare: Boolean; overload;<br />function IsRunningWine(var AWineVersion: string): Boolean; overload;<br />function IsRunningWine: Boolean; overload;<br />function IsRunningVirtualPC: Boolean;<br />function IsRunningVM(var AVMVersion: string): Boolean; overload;<br />function IsRunningVM: Boolean; overload;<br /><br />implementation<br /><br />uses<br /> SysUtils,<br /> Windows;<br /><br />function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;<br />const<br /> CVMWARE_FLAG = $564D5868;<br />var<br /> LFlag: Cardinal;<br /> LVersion: Cardinal;<br />begin<br /> LFlag := 0;<br /> try<br /> asm<br /> push eax<br /> push ebx<br /> push ecx<br /> push edx<br /><br /> mov eax, 'VMXh'<br /> mov ecx, 0Ah<br /> mov dx, 'VX'<br /><br /> in eax, dx<br /><br /> mov LFlag, ebx<br /> mov LVersion, ecx<br /><br /> pop edx<br /> pop ecx<br /> pop ebx<br /> pop eax<br /> end;<br /> except<br />// uncomment next two lines if you wish to see exception<br />// on E: Exception do<br />// ShowMessage(E.message);<br /> end; // trye<br /> if LFlag = CVMWARE_FLAG then begin<br /> Result := True;<br /> case LVersion of<br /> 1: AVMWareVersion := vvExpress;<br /> 2: AVMWareVersion := vvESX;<br /> 3: AVMWareVersion := vvGSX;<br /> 4: AVMWareVersion := vvWorkstation;<br /> else<br /> AVMWareVersion := vvUnknown;<br /> end<br /> end else begin<br /> Result := False;<br /> AVMWareVersion := vvNative;<br /> end; // if LFlag = CVMWARE_FLAG then begin<br />end;<br /><br />function IsRunningVMWare: Boolean;<br />var<br /> LVMWareVersion: TVMWareVersion;<br />begin<br /> Result := IsRunningVMWare(LVMWareVersion);<br />end;<br /><br />function IsRunningWine(var AWineVersion: string): Boolean;<br />type<br /> TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}<br /> TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}<br />var<br /> LHandle: THandle;<br /> LWineGetVersion: TWineGetVersion;<br /> LWineNTToUnixFileName: TWineNTToUnixFileName;<br />begin<br /> Result := False;<br /> AWineVersion := 'Unknown';<br /> LHandle := LoadLibrary('ntdll.dll');<br /> if LHandle > 32 then begin<br /> LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');<br /> LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');<br /> if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin<br /> Result := True;<br /> if Assigned(LWineGetVersion) then<br /> AWineVersion := StrPas(LWineGetVersion);<br /> end; // if Assigned(LWineGetVersion) or ...<br /> FreeLibrary(LHandle);<br /> end; // if LHandle > 32 then begin<br />end;<br /><br />function IsRunningWine: Boolean;<br />var<br /> LWineVersion: string;<br />begin<br /> Result := IsRunningWine(LWineVersion);<br />end;<br /><br />function IsRunningVirtualPC: Boolean;<br />asm<br /> push ebp;<br /> mov ebp, esp;<br /><br /> mov ecx, offset @exception_handler;<br /><br /> push ebx;<br /> push ecx;<br /><br /> push dword ptr fs:[0];<br /> mov dword ptr fs:[0], esp;<br /><br /> mov ebx, 0; // Flag<br /> mov eax, 1; // VPC function number<br /><br /> // call VPC<br /> db $0F, $3F, $07, $0B<br /><br /> mov eax, dword ptr ss:[esp];<br /> mov dword ptr fs:[0], eax;<br /><br /> add esp, 8;<br /><br /> test ebx, ebx;<br /><br /> setz al;<br /><br /> lea esp, dword ptr ss:[ebp-4];<br /> mov ebx, dword ptr ss:[esp];<br /> mov ebp, dword ptr ss:[esp+4];<br /><br /> add esp, 8;<br /><br /> jmp @ret1;<br /><br /> @exception_handler:<br /> mov ecx, [esp+0Ch];<br /> mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running<br /> add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC<br /> xor eax, eax; // exception is handled<br /><br /> @ret1:<br />end;<br /><br />function IsRunningVM(var AVMVersion: string): Boolean;<br />begin<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];<br /> Result := True;<br /> if IsRunningWine then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]<br /> else<br /> if IsRunningVMWare then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]<br /> else<br /> if IsRunningVirtualPC then<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualPC]<br /> else begin<br /> AVMVersion := VIRTUALMACHINE_STRINGS[vmNative]; <br /> Result := False;<br /> end;<br />end;<br /><br />function IsRunningVM: Boolean;<br />var<br /> LVMVersion: string;<br />begin<br /> Result := IsRunningVM(LVMVersion);<br />end;<br /><br />end.<br /></PRE>usage:<br />add uDGVMUtils to uses clause and:<br />// check if running in a virtual machine<br />var<br />LVMVersion: string;<br />begin<br />ShowMessageFmt('%s, VM name: %s', [BoolToStr(IsRunningVM(LVMVersion), True), LVMVersion]);<br />end;<br /><br />// check if running in wine<br />var<br />LWine: Boolean;<br />LWineVersion: string;<br />begin<br />ShowMessageFmt('Wine: %s, Wine ver.: %s', [BoolToStr(IsRunningWine(LWineVersion), True), LWineVersion]);<br />end;<br /><br />you get the picture, have fun!!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com6tag:blogger.com,1999:blog-7691723069373577907.post-75848982895785458292011-01-08T15:55:00.002+02:002011-01-08T15:57:58.763+02:00Client activity information in PostgreSQLIn most of my projects I use <a href="http://www.postgresql.org/">PostgreSQL</a> as database, I'm sure that if you see what you get for free, most of you will turn to it, anyhu' this post is about getting information from database, such as:<br />- databases to which has connections to it;<br />- current queries ran on X database and the timestamp when the query was started;<br />- ID's of processes;<br />- user name of connected clients;<br />- port on which each client is connected;<br />- client IP address;<br />- based upon above information we can get more special info regarding active connections;<br /><br />In order to see all of the above, run this query on the database:<br /><blockquote>SELECT * FROM PG_STAT_ACTIVITY;<br /></BLOCKQUOTE>The reason I was interested in this kind of information is that from time to time the database structure changes, therefore I need to run queries on previous database structures in order to fulfill latest needs, sooo... in order to upgrade the database I require that <b>NO</B> one else besides my "upgrade" application is connected to the database, therefore I run the following query in order to see to how many connections I have to X database, if the number of connections is greater than 1(if I'm connected to the database, I will be counted as well) then the application will wait until the number of connections to X database reaches 1 and then run the update queries, the query that I'm using is:<br /><blockquote>SELECT DATNAME AS "Database", COUNT(*) AS "ConnectionCount" FROM PG_STAT_ACTIVITY GROUP BY "Database";<br /></BLOCKQUOTE>and this will result in showing:<br /><table><tr> <th>Database</Th> <th>ConnectionCount</h> </TR><br /><br /><tr> <td>X db</TD> <td>2</TD> </TR><br /><br /><tr> <td>Y db</TD> <td>70</TD> </TR><br /><br /><tr> <td COLSPAN="2">etc.</TD> </TR><br /><br /></TABLE>Well that's about all that I wanted to point out for now, do you have any special queries you run on a PostgreSQL database and want to share? comment bellow and I will put above this final thought like:<br />Name:<br />SQL QUERYDorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-29107268875259609572011-01-01T00:38:00.000+02:002011-01-01T00:38:39.517+02:00Happy new year!!I wish you all a happy new year!!<br />Saale Nao Mubbarak<br />Gelukkige nuwe jaar<br />Gezuar Vitin e Ri<br />Snorhavor Nor Tari<br />Kul 'am wa antum bikhair<br />Sheta Brikhta<br />Yeni Iliniz Mubarek!<br />Noki saal mubarrak bibi<br />Shuvo Nabo Barsho<br />Bloavezh Mat<br />×åñòèòà Íîâà Ãîäèíà<br />Soursdey Chhnam Tmei<br />FELIÇ ANY NOU<br />Nuo bazzor bekkunore<br />Xin Nian Kuai Le<br />Pace e Salute<br />Sretna Nova godina!<br />Blwyddyn Newydd Dda<br />Šťastný Nový rok<br />Godt Nytår<br />Ufaaveri Aa Aharakah Edhen<br />GELUKKIG NIEUWJAAR!<br />Kiortame pivdluaritlo<br />Felican Novan Jaron<br />Head uut aastat!<br />MELKAM ADDIS AMET YIHUNELIWO!<br />RUHUS HADUSH AMET<br />Onnellista Uutta Vuotta<br />Bonne Annee<br />Bliadhna mhath ur<br />Bo Nadal e Feliz Aninovo<br />Prosit Neujahr<br />GILOTSAVT AKHAL TSELS!<br />Kenourios Chronos<br />Nutan Varshbhinandan<br />Hauoli Makahiki Hou<br />L'Shannah Tovah<br />Naye Varsha Ki Shubhkamanyen<br />Sun Leen Fai Lok<br />Boldog Új Évet Kivánok<br />Selamat Tahun Baru<br />Sal -e- no mobarak<br />Sanah Jadidah<br />Bliain nua fe mhaise dhuit<br />Felice anno nuovo<br />Akimashite Omedetto Gozaimasu<br />Asegwas Amegaz<br />Hosa Varushadha Shubhashayagalu<br />SOMWAKA OMOYIA OMUYA<br />Snem Thymmai Basuk Iaphi<br />Sua Sdei tfnam tmei<br />Saehae Bock Mani ba deu sei yo!<br />NEWROZ PIROZBE<br />Laimīgo Jauno Gadu!<br />Laimingu Naujuju Metu<br />Sabai dee pee mai<br />Srekjna Nova Godina<br />Tratry ny taona<br />Selamat Tahun Baru<br />Nveen Varshachy Shubhechcha<br />Puthuvatsara Aashamsakal<br />Kum Thar Chibai<br />Is-Sena t-Tajba<br />Nawa Barsha ko Shuvakamana<br />Godt Nyttår<br />Nua Barshara Subhechha<br />Nupela yia i go long yu<br />Masaganang Bayung Banua<br />Nawai Kall Mo Mubarak Shah<br />Sal -e- no mobarak<br />Manigong Bagong Taon!<br />Szczesliwego Nowego Roku<br />Feliz Ano Novo<br />Nave sal di mubarak<br />AN NOU FERICIT<br />S Novim Godom<br />Manuia le Tausaga Fou<br />Sretna nova godina<br />Nayou Saal Mubbarak Hoje<br />Subha Aluth Awrudhak Vewa<br />Nawan Saal Shala Mubarak Theevay<br />Stastny Novy rok<br />sreèno novo leto<br />Iyo Sanad Cusub Oo Fiican!<br />Feliz Ano ~Nuevo<br />Heri Za Mwaka Mpyaº<br />GOTT NYTT ÅR!<br />Warsa Enggal<br />Eniya Puthandu Nalvazhthukkal<br />Losar Tashi Delek<br />Noothana samvatsara shubhakankshalu<br />Sawadee Pee Mai<br />Yeni Yiliniz Kutlu Olsun<br />Shchastlyvoho Novoho Roku<br />Naya Saal Mubbarak Ho<br />Yangi Yil Bilan<br />Chuc Mung Tan Nien<br />Blwyddyn Newydd Dda!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-60890140098124073772010-12-22T18:22:00.000+02:002010-12-22T18:22:22.675+02:00Dynamic web pages with DWScript and IdHTTPServerI've finally found some time in my busy schedule to write a new post, this post is about generating dynamic web pages using DWScript(<a href="http://www.delphitools.info">http://www.delphitools.info</a> -- if you find DWScript useful please do not hesitate to donate to Eric, he is doing a wonderful job with DWScript) as script interpreter and IdHTTPServer as HTTP server.<br />But first let's understand the difference between static and dynamic web pages:<br />1. Static web pages:<br />- static web pages are just plain HTML files which will be manually updated by the developer or website owner whenever he wants;<br />Here's a drawing of the process that takes place in the case of static web pages<br /><br /><a href="https://sites.google.com/site/delphigeist/downloads/blogimg/static_webpage.png"><img SRC="https://sites.google.com/site/delphigeist/downloads/blogimg/static_webpage.png" WIDTH="470" HEIGHT="300"></IMG></a><br /><br />2. Dynamic web pages:<br />- dynamic web pages are similar to static HTML files, however this HTML files also contain script which is interpreted by a script interpreter which can be almost any script interpreter out there, i.e. perl, php, python, ruby, etc. for this example I've used DWScript;<br />Here's a drawing of the process that takes place in the case of dynamic web pages<br /><br /><a href="https://sites.google.com/site/delphigeist/downloads/blogimg/dynamic_webpage.png"><img SRC="https://sites.google.com/site/delphigeist/downloads/blogimg/dynamic_webpage.png" WIDTH="470" HEIGHT="300"></IMG></a><br /><br />as you can see the noticeable difference between static and dynamic web pages is the script interpreter which comes into play just before serving the HTML to the client.<br /><br />In this post I won't cover the benefits of using dynamic web pages and the possible exploits.<br /><br />For this post I've modified the HTTP server which I've created for a <a href="http://www.delphigeist.com/2010/11/dgtv-idhttpserver.html">video tutorial</a>, so here's the updated source of the uClientContext.pas file:<br /><pre>unit uClientContext;<br /><br />interface<br /><br />uses<br /> SysUtils,<br /> Classes,<br /> IdBaseComponent,<br /> IdComponent,<br /> IdCustomTCPServer,<br /> IdCustomHTTPServer,<br /> IdHTTPServer,<br /> IdContext,<br /> dwsComp,<br /> dwsCompiler,<br /> dwsExprs,<br /> dwsClassesLibModule,<br /> dwsMathFunctions,<br /> dwsStringFunctions,<br /> dwsStringResult,<br /> dwsTimeFunctions,<br /> dwsVariantFunctions,<br /> dwsHtmlFilter;<br /><br />type<br /> TClientContext = class(TIdServerContext)<br /> private<br /> FLogStrings: TStrings;<br /> procedure Log(const s: string);<br /> public<br /> procedure HandleRequest(ARequestInfo: TIdHTTPRequestInfo;<br /> AResponseInfo: TIdHTTPResponseInfo);<br /> procedure ServeHTMLFile(const AFileName: string;<br /> ARequestInfo: TIdHTTPRequestInfo;<br /> AResponseInfo: TIdHTTPResponseInfo);<br /> public<br /> property LogStrings: TStrings read FLogStrings write FLogStrings;<br /> end;<br /><br />implementation<br /><br />var<br /> WebDir: string;<br /><br />{ TClientContext }<br /><br />procedure TClientContext.HandleRequest(ARequestInfo: TIdHTTPRequestInfo;<br /> AResponseInfo: TIdHTTPResponseInfo);<br />const<br /> SERROR_404 = 'Error 404 page not found "%s"';<br />var<br /> LLocation: string;<br />begin<br /> try<br /> LLocation := ARequestInfo.Document;<br /> if LLocation <> EmptyStr then begin<br /> if (LLocation = '/') or (LLocation = '/*') or SameText(LLocation, '/index.html') then<br /> ServeHTMLFile(WebDir + 'index.html', ARequestInfo, AResponseInfo)<br /> else begin<br /> LLocation := WebDir + Copy(LLocation, 2, MaxInt);<br /> if NOT SameText(ExtractFileExt(LLocation), '.html') then<br /> LLocation := LLocation + '.html';<br /> if FileExists(LLocation) then<br /> ServeHTMLFile(LLocation, ARequestInfo, AResponseInfo)<br /> else<br /> AResponseInfo.ContentText := Format(SERROR_404, [LLocation]);<br /> end;<br /> end else<br /> AResponseInfo.ContentText := Format(SERROR_404, [LLocation]);<br /> except<br /> on E: Exception do<br /> Log('Exception occured from IP ' + Connection.Socket.Binding.PeerIP +<br /> sLineBreak + E.Message);<br /> end; // trye<br />end;<br /><br />procedure TClientContext.ServeHTMLFile(const AFileName: string;<br /> ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);<br />var<br /> LHTMLFile: TStringList;<br /> LScript: TDelphiWebScript;<br /> LHTMLFilter: TdwsHtmlFilter;<br /> LClasses: TdwsClassesLib;<br /> LProgram: TdwsProgram;<br />begin<br /> LScript := TDelphiWebScript.Create(NIL);<br /> LScript.Config.ScriptPaths.Add(WebDir);<br /> LClasses := TdwsClassesLib.Create(NIL);<br /> LHTMLFilter := TdwsHtmlFilter.Create(NIL);<br /> LScript.Config.Filter := LHTMLFilter;<br /> LScript.AddUnit(TdwsHtmlUnit.Create(LScript));<br /> LScript.AddUnit(Tdws2StringsUnit.Create(LScript));<br /> LHTMLFile := TStringList.Create;<br /> try<br /> LClasses.Script := LScript;<br /> LHTMLFile.LoadFromFile(AFileName);<br /> LProgram := LScript.Compile(LHTMLFile.Text);<br /> try<br /> if NOT LProgram.Msgs.HasErrors then begin<br /> LProgram.Execute;<br /> AResponseInfo.ContentText := (LProgram.Result as TdwsDefaultResult).Text;<br /> end else<br /> AResponseInfo.ContentText := LProgram.Msgs.AsInfo<br /> finally<br /> FreeAndNil(LProgram);<br /> end; // tryf<br /> finally<br /> FreeAndNil(LHTMLFile);<br /> FreeAndNil(LClasses);<br /> FreeAndNil(LScript);<br /> FreeAndNil(LHTMLFilter);<br /> end; // tryf<br />end;<br /><br />procedure TClientContext.Log(const s: string);<br />begin<br /> if Assigned(FLogStrings) then<br /> FLogStrings.Add(s);<br />end;<br /><br />initialization<br /> WebDir := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)) + 'www');<br /><br />end.<br /></PRE>as you can see the source code is pretty similar to the initial code, just that I've added a new method called <b>ServeHTMLFile</B> -- this method is called only if the requested HTML file is found in the www directory.<br /><b>Technique</B>: we don't create the interpreter instance unless the requested file is found in the www directory -- the reason is pretty obvious, we try to avoid memory allocation if it's not necessary, we could also improve the efficiency by caching the files in memory in order to serve them faster(RAM IO is faster than disk IO therefore this will give a significant speed improvement when server has thousands requests per second) however this will be covered in a future post hopefully.<br />In order to provide a proof of concept I've created a fairly simple "website" which has 3 buttons, each button redirects the client to a new web page:<br />index.html file<br /><pre><HTML><br /> <BODY><br /> Hello world!!<BR><br /> <BUTTON ONCLICK="window.location.href='/primes100.html'">show me primes up to 100</BUTTON> <BR><br /> <BUTTON ONCLICK="window.location.href='/primes200.html'">show me primes up to 200</BUTTON> <BR><br /> <BUTTON ONCLICK="window.location.href='/primes300.html'">show me primes up to 300</BUTTON> <BR> <br /> </BODY><br /></HTML><br /></PRE>very simple, right?<br />we also have a utils.inc file in which we have a method which checks if a number is prime, this file is also located in www directory<br /><pre>function IsPrime(Value: integer): boolean;<br />var<br /> Index: Integer;<br />begin<br /> Result := False;<br /> if Value <= 0 then<br /> Exit;<br /> for Index := 2 to Round(Sqrt(Value)) do<br /> if (Value mod Index) = 0 then<br /> Exit;<br /> Result := True;<br />end;<br /></PRE>here are the other 3 HTML files primes100.html <pre><HTML><br /> <BODY><br /> <%<br /> {$I 'utils.inc'}<br /> var<br /> Index: Integer;<br /> for Index := 1 to 100 do<br /> if IsPrime(Index) then<br /> Send('<BR>' + IntToStr(Index)); <br /> %><br /> </BODY> <br /></HTML><br /></PRE>primes200.html <pre><HTML><br /> <BODY><br /> <%<br /> {$I 'utils.inc'}<br /> var<br /> Index: Integer;<br /> for Index := 1 to 200 do<br /> if IsPrime(Index) then<br /> Send('<BR>' + IntToStr(Index)); <br /> %><br /> </BODY> <br /></HTML><br /></PRE>primes300.html <pre><HTML><br /> <BODY><br /> <%<br /> {$I 'utils.inc'}<br /> var<br /> Index: Integer;<br /> for Index := 1 to 300 do<br /> if IsPrime(Index) then<br /> Send('<BR>' + IntToStr(Index)); <br /> %><br /> </BODY> <br /></HTML><br /></PRE>Now, this is an extremely simple example, but as you can see it can be used as a template for a real hardcore web server. Unfortunately I don't have enough time these days for more in depth details, but you can download <a href="https://sites.google.com/site/delphigeist/downloads/binsrcDWScriptAndHTTPServer.zip">binary + source code</a> or <a href="https://sites.google.com/site/delphigeist/downloads/srcDWScriptAndHTTPServer.zip">just the source code</a> and enjoy the power and simplicity of DWScript.<br />The application is created in Delphi 2010.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-15319321184910582202010-11-30T13:36:00.000+02:002010-11-30T13:36:07.908+02:00Computing power: how much is enough?!I see almost every day someone showing off with their new hardcore computer with lots of Gigahertz and lots of RAM, etc. but is that system fast enough to find the first 100 mil. or 1 billion prime numbers in under 10 minutes?! well... it depends on the algorithms and the system configuration.<br />Time showed us that there's never enough computing power(I'm <B>NOT</B> talking about browsing the Internet or writing a text file here...), but what can we do in order to achieve our goals using computers as fast as possible?! there are a few options(off the top of my head):<br /><br />1. buy better computers<br />2. use any computer you can get you're hands on<br /><br /><font size="10"><B>1.</B></font> We always buy better computers in order to do stuff faster but there are a lot of limitations:<br /><B>a.</B> <U>budget</U>: we can buy STA(state of the art) computers with 4, 6, etc. cores that will make our life easier, but is this really a good idea?! the answer is <B>NO</B>, buying a i7 at 3 GHz with 4 cores it's about $ 3-400 depending in which country you live, now 3 Ghz with 4 cores is not the fastest you can get, Intel has way better CPU's than that -- extreme series, they also try to get as many cores as they can into a CPU but let's just stop at the extreme series which costs about $ 1.000/CPU(of course it worths the price, but it depends on your <B>needs</B>) -- now this is a lot just for a processor but depending on you're budget you can buy or skip.<br /><br /><B>b.</B> <U>operating system</U>: some OS's are better than others -- depending on your needs of course -- let's take Windows for example, it is a very good OS for entertainment and office, but when you need to do some tasks that takes hours/days/weeks to complete is it good?! I honestly can't give a definitive answer on this because for tasks that needs a lot of time to complete I turn to my geek friend <B><U>Linux</U></B> -- it is very stable, it manages resources very well and if you don't need GUI(graphical user interface) it's pretty much rock-solid.<br /><br /><font size="10"><B>2.</B></font> What do I mean by "use any computer you can get you're hands on"?!<br />It's not a secret that a lot of companies connect a bunch of computers together through a communication protocol and use each computer as a thread -- WAIT!! how does this work?!!<br />Basically it depends on the developers... you can have a system that is the <B>Master</B> on which you execute <B>special programs</B> and sends task execute request to 2 or more <B>Slaves</B>, when a slave completed it's task, it sends back the result to the master and waits for another request from the master -- pretty simple ey?! in essence yes, in practice <B>NOT</B>!!<br />Here is the basic idea:<br />step 1. Master => send request => slave(s)(1..N computers) -- usually at least 2!!<br />step 2. Master waits for all slaves to complete the tasks<br />step 3. when a slave completes the task it sends result back to the Master<br />step 4. Master processes result(s)<br />Fairly simplistic right?! but why do I say "at least 2 computers"?!<br />Over time we have been Witness hardware failure(I'm proud that I haven't had too many -- yet!!) let's say we got a highly intensive task that we believe that it will take "forever" to complete a matter of days, <B>WHAT IF</B> in this time one of the slaves has a hardware failure?! you've lost shit-load of time and we all know the equation:<br /><B>time = money -> lose time => lose money</B> another way to see this is: the less time you spend on doing something, the more money you earn.<br />Sooo... let's review what is one of the best approaches you can take when you need huge computing power:<br />1. get as many systems as you can -- no matter how powerful the CPU is or how much RAM the system has<br />2. implement the logic and the communication protocol(avoid using hard disks as much as possible <-- slowest part in the computer) 3. start using you're new hardcore computer network <B>4...N. always improve the idea!!</B><br /><br />Now, let's try to throw some ideas of a possible implementation:<br />- create a flexible communication protocol(I prefer using TCP/IP because you can have GB's of data transfered in second(s)) maybe use XML?!<br />- choose the cleanest Linux distribution you can think of -- avoid using GUI for better performance(on slave side)<br />- implement integer(huge integers -- that can grow up to trillion digits long), string(huge strings that can be concated from 2 or more slaves), object(which has it's own methods which will be transfered along with it from master-slave, slave-master, slave-slave), etc.<br />- use some kind of ping mechanism so that the Master is automatically "knows" when a slave is dead and take appropriate actions(send task to another slave, e-mail tech department, etc.)<br />- Master CAN NOT execute task -- it needs only to assign tasks to slaves and communicate with them<br />- if you try hard enough you can also make the slaves "know" when the Master has a failure and another "free of task" slave can take it's place<br />- you will have to use a very fast interpreter<br /><br />What do we get out of this?! well some of you know that you can buy good old Pentium 4 computers at 2.x-3 Ghz with 512 mb or 1 GB RAM for ~$ 100) -- WAIT!! so I can have 10 cores at $ 1.000?!?! yup...<br />You can also use implement this in such a away that you can use virtually any OS -- YES you can have 2 slaves on Windows 2000, 5 slaves on Windows XP, 20 slaves on Linux, 8 slaves on OSX, etc.<br />Sooo... the "hardcore" system can have a lot of slaves, running on multiple platforms AND you can always ADD more slaves on the network, OK but where's the drawback, I know there must be at least one -- yes there are plenty, but it basically depends on the developer(s):<br />- the system can take anywhere between a few seconds to a few minutes(depending on the initialization implementation -- needs to be ran at the beginning of the program execution) -- this can be tunned!!<br />- you will have to take care of the synchronization -- it's normal in a multithreaded environment<br />- if master dies the whole program progress can be lost -- this depends entirely on the implementation of the "main executor" or <B>Mr. X</B> ;-)<br />- you also need to take into consideration each system's configuration -- depending on this you can execute small tasks on Pentium 3 systems and others on P4 or i3/5/7's<br /><br />As you can see the most important piece of the puzzle is the <B>developer's skills</B>.<br /><br />But sometimes you need tens of thousands of computers -- WHAT can you do then?!<br />We all know that there are hundreds of millions of computers out there that are used only for Internet browsing, multimedia download, how can we use that to our advantage?! well a lot of hackers and companies uses/d <a href="http://en.wikipedia.org/wiki/Zombie_computer">zombie computers</a> by uploading torrent clients and or multimedia programs for users to freely download and use, but while a lot of computers spend hours a day just downloading, the CPU and a lot of memory is available to be freely used legally or illegally depending on the <a href="http://en.wikipedia.org/wiki/Software_license_agreement">EULA</a> they provided with the software.<br />Take <a href="http://www.skype.com/intl/en/home">Skype</a> for example, it uses your <B>CPU</B> and <B>bandwidth</B> in order to provide you with "free" service:<br /><BLOCKQUOTE>4.1 Permission to utilize Your computer. In order to receive the benefits provided by the Skype Software, You hereby grant permission for the Skype Software to utilize the processor and bandwidth of Your computer for the limited purpose of facilitating the communication between Skype Software users.<br /><br />4.2 Protection of Your computer (resources). You understand that the Skype Software will use its commercially reasonable efforts to protect the privacy and integrity of Your computer resources and Your communication, however, You acknowledge and agree that Skype <font size="10"><B>cannot</B></font> give any warranties in this respect. <br /><br /><B>You hereby grant permission for the Skype Software to utilize the processor and bandwidth of Your computer for the limited purpose of facilitating the communication between Skype Software users.</B><br /></BLOCKQUOTE>This is a <I>legal</I> way of using your system, however others are JUST using your system because you got some illegal software from a torrent or warez website and you can't really complain about this in court, if you know what I mean -- it's your full <B>responsibility</B>.<br /><br />As a Delphi/Pascal developer, what can you use in order to target as many platforms as you can and implement this? <B>HELLO?!?!</B> <a href="http://www.freepascal.org/">Freepascal</a> and <a href="http://www.lazarus.freepascal.org/">Lazarus</a> is a good starting point and DO NOT forget that as a developer you should NOT be limited to a single programming language, you can also use C++ and/or Java as well if you implement your protocol flexible enough!!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com3tag:blogger.com,1999:blog-7691723069373577907.post-50354994698538455522010-11-18T10:11:00.002+02:002010-11-21T18:22:35.745+02:00Delphi XE Distiller<a href="http://www.torry.net/tools/project/projects/XEDistiller1.0.0.9.zip">Sooo... there's another Delphi Distiller available for those of you who wishes to download click this text(version 1.0.0.9).</a>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com10tag:blogger.com,1999:blog-7691723069373577907.post-39524091981640845172010-11-05T00:23:00.003+02:002010-11-05T01:45:52.257+02:00DGTV: IdHTTPServerA new video tutorial is available, in this tutorial I'm explaining how to create a very basic HTTP server application, please watch it in HD for best experience, any comments are welcomed.<br />Part 1<br /><object width="960" height="745"><param name="movie" value="http://www.youtube.com/v/WrKQGRhs4CQ?fs=1&hl=en_US&hd=1"></param><param name="allowFullScreen" value="true"></param><param name="allowscriptaccess" value="always"></param><embed src="http://www.youtube.com/v/WrKQGRhs4CQ?fs=1&hl=en_US&hd=1" type="application/x-shockwave-flash" allowscriptaccess="always" allowfullscreen="true" width="960" height="745"></embed></object><br /><br />Part 2<br /><object width="960" height="745"><param name="movie" value="http://www.youtube.com/v/kRivbiKyMBk?fs=1&hl=en_US&hd=1"></param><param name="allowFullScreen" value="true"></param><param name="allowscriptaccess" value="always"></param><embed src="http://www.youtube.com/v/kRivbiKyMBk?fs=1&hl=en_US&hd=1" type="application/x-shockwave-flash" allowscriptaccess="always" allowfullscreen="true" width="960" height="745"></embed></object>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com3tag:blogger.com,1999:blog-7691723069373577907.post-80081786170553578742010-11-03T01:14:00.002+02:002010-11-05T00:19:42.616+02:00DGTV: VirtualStringTreeI've created my first Delphi video tutorial which covers the basic use of VirtualStringTree component, please see it @ 720p for best experience.<br />Leave comments of what subject should I cover in a future video.<br /><object width="960" height="745"><param name="movie" value="http://www.youtube.com/v/o6FpUJhEeoY?fs=1&hl=en_US&hd=1"></param><param name="allowFullScreen" value="true"></param><param name="allowscriptaccess" value="always"></param><embed src="http://www.youtube.com/v/o6FpUJhEeoY?fs=1&hl=en_US&hd=1" type="application/x-shockwave-flash" allowscriptaccess="always" allowfullscreen="true" width="960" height="745"></embed></object>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com4tag:blogger.com,1999:blog-7691723069373577907.post-27536614610698508502010-11-02T15:44:00.001+02:002020-07-17T03:27:58.570+03:00Delphi 2010 or XE?!OK, so we had a Delphi 2010 release and a couple of months later a Delphi XE(cool name huh?) release, your confused, what's the logic behind that? no cross platform, no 64 bit compiler nothing new actually besides the XE suffix, some IDE fixes and some light versions of third party tools.<br />All this still doesn't make sense... let's try a different approach: we know that the end goal of a company is to maximize their profits right?! if they have released Delphi 2010 without the IDE glitches it would have taken them a few months more to release Delphi 2010, that means that they would have "lost" money, what they(management) choose to do is release a Delphi 2010(I really hate this kind of names with suffix "year of release" sounds really nasty!!) and after the IDE fixes a new version would be released(in this case XE) — sweet, the only problem is that people who have already purchased 2010 version have spent some money on a product which is NOT, I REPEAT NOT really good for big projects which involves thousands and thousands of lines of code — takes way too many freaking minutes or tens of minutes to build in order to test.<br />Does now make sense?! of course it does, but if your a customer, you're not "so" happy about this approach, Visual Studio has better releases as I've seen the last couple of years — this really bugs me!!<br />When I've tested XE(for a couple of minutes), I've seen faster IDE, less glitches, overall XE is a bit better than 2010, the only issue is that you have to spend more freaking money, what was my response to this?! invested $ 1.000 in a i7, memory and a good mother board — why?! well.. instead of giving them a couple of hundred Euros for something they should have giving in the 2010 release, I've upgraded my system which is a 2 years investment at least and give them s**t. Delphi 2010 runs smoothly now, I got a faster system, Intel, ASUS and Kingston got some money from me, problem solved!<br />---<br /><b>Now I know what some of you might say</b>: if you're a developer who makes money out of this, why NOT buy the latest releases since it's just a few hundred Euros/Dollars?! well the response is simple, while a company tries to maximize their profits, you as a developer(in this case customer) need to minimize your expenses — learn from your clients!!Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com8tag:blogger.com,1999:blog-7691723069373577907.post-7351055276095305672010-10-22T12:58:00.001+03:002010-10-22T12:59:44.637+03:00Sooo you got your first milion, now what?!Let's just say that you just won € 1.7 mil. in lottery(tax free). What would you do with that much money in the current economy state?!<br />There are lots of things you can do with it, but the million euro question is: <b><u>What's the best thing you can do with it</U></B>, for you and MAYBE for others as well.<br /><u>Let's just list a few possibilities</U>:<br />- quit the job and waste the money;<br />- give the money to homeless people and help them start a fresh new life;<br />- give it to charity;<br />- start your own company(what kind of company, most of you that read this blog are developers, would you start a software company or do you think you can squeeze more money in other fields?!);<br />- buy the company in which you currently work(I'm sure it applies to many of you out there);<br />- buy a bigger house, bigger car, lots of bling-blings and biaches(I'm sure some of you want that -smile-);<br />- hold on to the money since there's no certain future coming;<br />- keep the money until pension, waste it then;<br />The above list is just off the top of my head — I disagree with at least half of the list — <b>BUT</B> I'm curious what other people would do with that much money.<br /><hr>No matter what you would do, consider this: money come and go, you're current job(if applies) is most likely pretty steady, you should take a deep breath before starting to think about how would you spend it and on what.<br />P.S. Don't forget, you also lose money(inflation which is a pretty big percent, let's say about 2%/year in Germany's or USA's case) by keeping it „safe¯ with each year.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com2tag:blogger.com,1999:blog-7691723069373577907.post-11701272287751188572010-10-14T21:44:00.000+03:002010-10-14T21:44:13.621+03:00Message dialogs: you're doing it wrong...No matter what you say or think, end-users are beasts, they will always find a way to make their life more complicated instead of reading messages or instructions...<br />I'm pretty sure AT least once in your life you pressed the wrong button on a message dialog, because you „thought¯ you know what it will ask you OR because you was in a hurry...<br />The main problem with the end-user is that (s)he will do this most of the times, let's suppose that you're asking the user if (s)he is sure to wipe a file or discard changes that are very important to him/her, even if the user should be blamed because (s)he didn't read the message, you're still the one that will be sweared.<br />So what can we do to overcome such a situation?! well not much without stressing the user <B>BUT</B> we can use a timed message dialog with which the user cannot interact for a amount of time — this will probably force the user to read the freaking message!<br />So here's my implementation of a timed message dialog:<br /><PRE>unit uTimedMessageDlg;<br /><br />interface<br /><br />uses<br /> SysUtils,<br /> Windows,<br /> Classes,<br /> Forms,<br /> Dialogs,<br /> Controls,<br /> ExtCtrls;<br /><br />const<br /> CDEFAULT_WAIT_SEC = 10;<br /> CSECOND = 1000;<br /> CTIMED_MESSAGE = '%s (%d seconds)';<br /><br />type<br /> TTimedMessageDlg = class(TObject)<br /> private<br /> FTimer: TTimer;<br /> FSeconds: Cardinal;<br /> FMessageForm: TForm;<br /> FCountDown: Integer;<br /> FCaption: string;<br /> procedure OnTimer(Sender: TObject);<br /> procedure OnDialogShow(Sender: TObject);<br /> public<br /> constructor Create;<br /> destructor Destroy; override;<br /> public<br /> function DisplayDialog(const Msg: string; const Args: array of const;<br /> DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;<br /> const SecondsToWait: Cardinal = 10): Integer;<br /> public<br /> property Seconds: Cardinal<br /> read FSeconds write FSeconds;<br /> end;<br /> <br />function TimedMessageDlg(const Msg: string; const Args: array of const ;<br /> DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;<br /> const SecondsToWait: Cardinal): Integer;<br /><br />implementation<br /><br />{ TTimedMessageDlg }<br /><br />constructor TTimedMessageDlg.Create;<br />begin<br /> FTimer := TTimer.Create(NIL);<br /> FTimer.Enabled := False;<br /> FTimer.Interval := 1000;<br /> FTimer.OnTimer := OnTimer;<br /> FSeconds := 10;<br />end;<br /><br />function TTimedMessageDlg.DisplayDialog(const Msg: string;<br /> const Args: array of const;<br /> DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;<br /> const SecondsToWait: Cardinal = 10): Integer;<br />begin<br /> FMessageForm := CreateMessageDialog(Format(Msg, Args), DlgType, Buttons);<br /> FMessageForm.OnShow := OnDialogShow;<br /> FCountDown := SecondsToWait -1;<br /> FCaption := FMessageForm.Caption;<br /> FMessageForm.Caption := Format(CTIMED_MESSAGE, [FCaption, FCountDown]);<br /> FTimer.Interval := 1000;<br /> FTimer.Enabled := True;<br /> Result := FMessageForm.ShowModal;<br /> FreeAndNil(FMessageForm);<br />end;<br /><br />destructor TTimedMessageDlg.Destroy;<br />begin<br /> FreeAndNil(FTimer);<br /> inherited;<br />end;<br /><br />procedure TTimedMessageDlg.OnTimer(Sender: TObject);<br />begin<br /> Dec(FCountDown);<br /> FMessageForm.Caption := Format(CTIMED_MESSAGE, [FCaption, FCountDown]);<br /> if FCountDown <= 0 then begin<br /> FMessageForm.Caption := FCaption;<br /> FTimer.Enabled := False;<br /> FMessageForm.Enabled := True;<br /> end; // if FCountDown <= 0 then begin<br />end;<br /><br />procedure TTimedMessageDlg.OnDialogShow(Sender: TObject);<br />begin<br /> FMessageForm.Enabled := False;<br />end;<br /><br />function TimedMessageDlg(const Msg: string; const Args: array of const ;<br /> DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;<br /> const SecondsToWait: Cardinal): Integer;<br />var<br /> TimedMessage: TTimedMessageDlg;<br />begin<br /> TimedMessage := TTimedMessageDlg.Create;<br /> Result := TimedMessage.DisplayDialog(Msg, Args, DlgType, Buttons,<br /> SecondsToWait);<br /> FreeAndNil(TimedMessage);<br />end;<br /><br />end.<br /></PRE>Sooo... what's the difference between normal and this custom message dialog?! nothing much, just that it can also format your message if you wish to <B>AND</B> the user <B><U>cannot</U></B> close or press any button on the message for the specified amount of time — I suggest to keep the time-out value somewhere between 3 to 7 seconds max.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-28016481647932995272010-10-12T04:58:00.000+03:002010-10-12T04:58:58.974+03:00Fun with callbacks and progress formSome time ago I needed to display a progress form in order to give feedback to the user on current state of the task, therefore the „challenge¯ is pretty simple: a secondary form that will have a label — to display some info on current task — and two progress bars — for visual feedback — 1 progress bar for the „overall progress¯ and the other one for „current progress¯, this means that we have a task which is composed of few steps and each step has it's own progress.<br />Sooo... the MAIN idea is that the progress form needs to be displayed as modal while also calling a method(procedure) from another unit — this is where callbacks come into play.<br />What are callbacks?!<br /><blockquote><b><br />A callback is a reference to executable code, or a piece of executable code, that is passed as an argument to other code. This allows a lower-level software layer to call a subroutine (or function) defined in a higher-level layer.<br /></B></BLOCKQUOTE><a href="https://sites.google.com/site/delphigeist/downloads/dgProgressCallback.zip">For a better understanding of this article click this text to download the source code.</a><br />Let's achieve the same thing in a new project:<br />- add a button to this form<br />- add a new form to this application, remove it from auto-create forms(Project->Options->Forms)<br />- add two labels and two progress bars to the second form<br />- set the caption of one label to „Overall progress¯ and to the other label „Current progress¯<br />- name one progress bar „pbOverall¯ and the other „pbCurrent¯<br />Now let's write some code, first define the callback method as<br /><pre><b>type</B><br /> TProgressCallback = <b>procedure</B> (InProgressOverall, InProgressCurrent: TProgressBar) <b>of Object</B>;<br /></PRE>we will pass „pbOverall¯ and „pbCurrent¯ as parameters in the callback method.<br />It's time to define a generic method that will create a new instance of our progress form in order to display a modal progress<br /><pre><b>procedure</B> ShowProgress(InCallback: TProgressCallback);<br /><b>var</B><br /> LWindowList: TTaskWindowList;<br /> LSaveFocusState: TFocusState;<br /> LProgressForm: TfrmProgressForm;<br /><b>begin</B><br /> // create the instance<br /> LProgressForm := TfrmProgressForm.Create(<b>NIL</B>);<br /> <b>try</B><br /> // save the focus state<br /> LSaveFocusState := SaveFocusState;<br /> // save the focused form<br /> Screen.SaveFocusedList.Insert(0, Screen.FocusedForm);<br /> // notify that a form will be displayed as modal<br /> Application.ModalStarted;<br /> // disable all other forms<br /> LWindowList := DisableTaskWindows(0);<br /> // set the progress form instance as the screen focused form <br /> Screen.FocusedForm := LProgressForm;<br /> // send a active message<br /> SendMessage(LProgressForm.Handle, CM_ACTIVATE, 0, 0);<br /> // show the form<br /> LProgressForm.Show;<br /> // InCallback is our callback method to which we pass pbOverall and pbCurrent<br /> // as parameters so we can play with them later<br /> InCallback(LProgressForm.pbOverall, LProgressForm.pbCurrent);<br /> // after the callback is executed enable windows<br /> EnableTaskWindows(LWindowList);<br /> // restore focus state<br /> RestoreFocusState(LSaveFocusState);<br /> <b>finally</B><br /> // notify that we're leaving a modal state<br /> Application.ModalFinished;<br /> // free and nil the progress form instance<br /> FreeAndNil(LProgressForm);<br /> <b>end</B>;<br /><b>end</B>;<br /></PRE>all we have left to do now is to define a (private or public)method in main form with same parameters as the callback method like so:<br /><pre><b>type</B><br /> TForm1 = <b>class</B>(TForm)<br /> Button1: TButton;<br /> <b>procedure</B> Button1Click(Sender: TObject);<br /> <b>private</B><br /> // this is our callback method<br /> <b>procedure</B> ProgressCallback(InProgressOverall, InProgressCurrent: TProgressBar);<br /> <b>public</B><br /> { Public declarations }<br /> <b>end</B>;<br /></PRE>in the implementation section copy-paste this code<br /><pre><b>procedure</B> TForm1.ProgressCallback(InProgressOverall,<br /> InProgressCurrent: TProgressBar);<br /><b>var</B><br /> Index: Integer;<br /> kIndex: Integer;<br /><b>begin</B><br /> MessageDlg('Press OK to start a long task...', mtInformation, [mbOK], 0);<br /> // 10 steps<br /> InProgressOverall.Max := 10;<br /> // 3000 updates per step<br /> InProgressCurrent.Max := 3000;<br /> <b>for</B> Index := 1 <b>to</B> InProgressOverall.Max <b>do begin<br /> for</B> kIndex := 1 <b>to</B> InProgressCurrent.Max <b>do begin</B><br /> InProgressCurrent.Position := kIndex;<br /> // force application to process messages<br /> Application.ProcessMessages;<br /> <b>end</B>; // for kIndex := 1 to InProgressCurrent.Max do begin<br /> InProgressOverall.Position := Index;<br /> // force application to process messages<br /> Application.ProcessMessages;<br /> <b>end</B>; // for Index := 1 to InProgressOverall.Max do begin<br /> MessageDlg('Task completed!', mtInformation, [mbOK], 0);<br /><b>end</B>;<br /></PRE>on the main form you have a button, in it's OnClick event add the following code:<br /><pre>ShowProgress(Self.ProgressCallback);<br /></PRE>Any ideas on how to achieve the same effect in less code or more elegant?! please leave comment.Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0tag:blogger.com,1999:blog-7691723069373577907.post-588099153793660302010-09-28T04:08:00.000+03:002010-09-28T04:08:24.965+03:00How to save a report as PDF to a stream with FastReportRecently I needed to save a report to a stream as PDF, I'm using <a href="http://fast-report.com/en/">FastReport</a> for my reports.<br />I've searched a lot for a way to do this, but unfortunately I only found comments like „you can't export a report to a stream in PDF format with FastReport¯ and similar comments... so I started browsing the source code of the PDF exporter and 2 minutes later I saw that the exporter checks if property „Stream¯ is assigned, otherwise it will create a TFileStream instance using the report's „FileName¯ property — therefore assigning a TStream descendant to PDFExporter.Stream will make the exporter write the PDF data to THAT stream in stead of the file, without further chit-chat, let's see some code:<br />I took „PrintStringList¯ example from the Demo folder and modified it to show you how it's done, I've added a new button on the form and a save dialog, in the OnClick event of the button I've added the following code:<br /><pre>procedure TForm1.Button2Click(Sender: TObject);<br />var<br /> // we use a file stream for example, but you can replace this<br /> // with a memory stream or any type of stream which is a<br /> // descendant of abstract class TStream<br /> LFileStream: TFileStream;<br />begin<br /> // allow the user to choose a file name<br /> if SaveDialog1.Execute then begin<br /> // create the file stream object<br /> LFileStream := TFileStream.Create(SaveDialog1.FileName, fmCreate or fmShareDenyNone);<br /> try<br /> // set the range properties<br /> StringDS.RangeEnd := reCount;<br /> StringDS.RangeEndCount := sl.Count;<br /> // THIS IS THE MAGIC<br /> // assign the stream for the TfrxPDFExport component<br /> frxPDFExport1.Stream := LFileStream;<br /> // prepare the report<br /> frxReport1.PrepareReport(True);<br /> // export calls the PDFExport component in this case<br /> frxReport1.Export(frxPDFExport1);<br /> finally<br /> // free the file stream object<br /> FreeAndNil(LFileStream);<br /> // NIL reference to the stream<br /> frxPDFExport1.Stream := NIL;<br /> end; // tryf<br /> end; // if SaveDialog1.Execute then begin<br />end;<br /></pre><b>NOTE: you need FastReport installed!!</b><br /><a href="https://sites.google.com/site/delphigeist/downloads/PrintStringList_modified.zip">You can download the entire project source code by clicking on this text.</a>Dorin Duminicahttp://www.blogger.com/profile/02436024025965763054noreply@blogger.com0