Tuesday, September 29, 2009

How to change a window's caption

I've notice that a remarkable number of people are searching for a method to change a window's caption, well this can be achieved by a simple function called SetWindowText and it's defined as
function SetWindowText(hWnd: HWND; lpString: PWideChar): BOOL; external user32 name 'SetWindowTextW';

all you need to do is to know the caption of the window you want to change caption or have it's handle, i.e.
procedure ChangeNotepadCaption;
var
  hNotepad: HWND;
begin
  hNotepad := FindWindow(nil, 'Untitled - Notepad');
  SetWindowText(hNotepad, 'Delphi 2010 change caption demo :)');
end;

or if you only know a part of the caption(or the caption is constantly changing) which does not change no matter what then you can find that window with FindWindowExtd that can be found at an older post fallowing this link.

Very simple Virtual Treeview tutorial

Yeah... I know how you(beginner) feel when it comes to Virtual Treeview from Soft-Gems.net, it's to hard to use!.
Take a deep breath as I guide you from "nub to intermediate" in under 20 minutes, all you need is:
 - to have a delphi installed on your system(if running then close it)
 - get Virtual Treeview from this link, click on Virtual Treeview Windows distribution
 - install it
Now we're going to do this step by step, but first start delphi then go to File -> New -> VCL Forms application - Delphi, add a TVirtualStringTree on the form from the "Virtual Controls" tab. As you can see from object inspector you got "stuff" load of options don't modify anything yet! go to events and find an event named OnGetNodeDataSize double-click the combobox on it's right and copy-paste this code
procedure TForm1.VirtualStringTree1GetNodeDataSize(Sender: TBaseVirtualTree;
  var NodeDataSize: Integer);
begin
  NodeDataSize := sizeof(PString);
end;

with the above code we tell the tree the size of each item we will display in it.
Now drop a button on a form, double-click it and copy-paste this code
procedure TForm1.Button1Click(Sender: TObject);
var
  index: integer;
  data: PString;
begin
  VirtualStringTree1.BeginUpdate;
  for index := 0 to 1000 do begin
    data := VirtualStringTree1.GetNodeData(VirtualStringTree1.AddChild(nil));
    data^ := Format('node #%d', [index]);
  end;
  VirtualStringTree1.EndUpdate;
end;

at this point we got everything we need except the event which needs to know the string it should display, so in order to fix this we need to search on our VirtualStringTree1's events for an event named OnGetText, copy-paste this code
procedure TForm1.VirtualStringTree1GetText(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;
  var CellText: string);
var
  data: PString;
begin
  data := Sender.GetNodeData(Node);
  CellText := data^;
end;

I didn't comment this code because if you want a bit more complicated example you can browse thorough soft-gems.net or download a demo application which I made specially for this tutorial, it is well commented and above all seeing is buliving.

Get integer bits

Did you ever needed/wanted to see an integer as 0's and 1's I mean in binary form? I'm more than sure you did/do, here is a method to see if a bit of an integer variable is ON or OFF
function GetBitState(Num, BitNum: Cardinal): Boolean;
asm
    BT   Num, BitNum
    SETC al
end;

The above function returns True if bit is ON and False if bit is OFF, now let's use this function to get a 32 char string so we can see how what's the binary form of a integer, before the actual function we need an intermediate function which translates True and False into 0 and 1 char
function BoolToChar(Value: Boolean): Char;
begin
  if Value then
    Result := '0' else
    Result := '1';
end;

now all we need the function which translates an integer to a "string of bits"
function GetIntBits(Value: Integer): String;
var
  index: Integer;
begin
  SetLength(Result, 32);
  for index := 0 to 31 do
    Result[index +1] := BoolToChar(GetBitState(Value, index));
end;

Example of usage
ShowMessage(GetIntBits(2009));
and the result should be
01100100000111111111111111111111
I can think of only two things(right now...) that would make this methods useful:
a) some sort of compression method
b) some sort of encryption algorithm

Sunday, September 27, 2009

How to create a virtual drive

This is a very simple method to create a new drive which links to a folder, for example: let's say we want a new drive letter(W) which points to our Delphi components folder(D:\Delphi\Components\).
Create a new VCL application, drop 2 buttons on the form, change caption of Button1 to CreateDrive and the caption of Button2 to RemoveDrive, paste the fallowing 3 methods after the implementation keyword
function SystemDir: string;
begin
  (* get system32 folder *)
  SetLength(Result, MAX_PATH);
  GetSystemDirectory(@Result[1], MAX_PATH);
end;

procedure DriveLinkCreate(const Drive: Char; const Path: String);
var
  Param: String;
begin
  (* format the call parameter *)
  Param := Format('%s: "%s"', [Drive, Path]);
  (* and bang! we get a new drive *)
  ShellExecute(1, 'open', 'subst', PChar(Param),
    PChar(SystemDir), 0);
end;

procedure DriveLinkRemove(const Drive: Char);
var
  Param: String;
begin
  (* format the call parameter with the /d option
     which stands for delete *)
  Param := Format('%s: /d', [Drive]);
  (* now we remove the virtual drive *)
  ShellExecute(1, 'open', 'subst', PChar(Param),
    PChar(SystemDir), 0);
end;

now press F12 to see the form, double-click the CreateDrive button and paste the fallowing code
  DriveLinkCreate('W', 'D:\Delphi\Components');

replace 'D:\Delphi\Components' with your delphi component folder
press F12 again and double-click the RemoveDrive button and paste this code
  DriveLinkRemove('W');

Don't forget to add ShellApi to uses clause.
That's it, if you have any questions don't hesitate to ask.

Friday, September 25, 2009

The absolute directive

This post is the about Delphi's absolute directive, according to Delphi 7 Help file
You can create a new variable that resides at the same address as another variable. To do so, put the directive absolute after the type name in the declaration of the new variable, followed by the name of an existing (previously declared) variable. For example,
var
  Str: string[32];
  StrLen: Byte absolute Str;

specifies that the variable StrLen should start at the same address as Str. Since the first byte of a short string contains the string's length, the value of StrLen is the length of Str.
You cannot initialize a variable in an absolute declaration or combine absolute with any other directives.

If that makes you dizzy then let's say you want to get a byte from a 32 bit integer(a 32 bit integer is represented on 4 bytes) then with the help of absolute directive we can use this
function getIntByte(thisInteger: Integer; ByteIndex: Byte): Byte;
var
  int_bytes: array[0..3] of Byte absolute thisInteger;
begin
  Result := int_bytes[ByteIndex];
end;

now if we want to get the second byte from the integer we can just use
getIntByte(1), because 0 is the first byte, 1 is the second and so on.
Usage example
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(getIntByte(2009, 1)));
end;

So... the absolute directive actually gives you access to a variable/parameter's memory for example if you need to get a string as an array of bytes you can simply use
procedure StrAsArrayOfByte(thisString: String);
var
  str_bytes: array of byte absolute thisString:
begin
  (* do something with "str_bytes" *)
end;

The possibilities are enormous, you just need to know when to use it, in stead of copying a variable's chars to an array of byte or using Ord(myString[Index]) just use the absolute directive!
Do not hesitate to post comments!!

Thursday, September 24, 2009

Play with memory

If you ever need to play with raw memory then this tutorial is a start.
I will explain a bit about AllocMem, ReallocMem, ZeroMemory, MoveMemory, CopyMemory, FillMemory, FillChar, FreeMem methods in this tutorial.
Before we start let's talk about bits 'n' bytes 'n' stuff, you must know that 1 byte is equal to 1 octet or 8 bits, a bit can have value 0(True) or 1(False), now... 1 byte can have value from 0 to 255 that's 256 values(255 + 1(which is 0)).
Word is represented on 2 bytes so it's 2(bytes) * 8(bits per byte) = 16 bits, get it? if not it's ok read on.
Integer(32 bits) is represented on 4 bytes so it's 4(bytes) * 8(bits per byte) = 32 bits it's about time you get the idea.
Int64(integer represented on 64 bits) is represented on 8 bytes so it's 8(bytes) * 8(bits per byte) = 64 bits.
Double value is represented on 8 bytes as Int64.
From now on if someone asks you: What is an octet?
You should be able to answer: 1 Byte or 8 Bits!
Now let's start talking about memory, consider memory as a pack of bytes, let's say you wish to allocate 4 bytes to a pointer(a pointer is a reference to a memory block, it holds the address) then store "2009" value in that allocated memory then free it, in Delphi you can do it this way(or use a memory stream :))
procedure MyFirstMemoryAllocation;
var
  (* the pointer I was talking about *)
  myPointer: Pointer;
begin
  (* allocate memory, self explained, I've
     allocated 4 bytes in this case, but I could
     have also used 2 because the maximum value
     you can store on 2 bytes is 65535, that's
     256 * 256 -1 *)
  myPointer := AllocMem(4);
  (* store the value on "myPointer" using a hard
     cast, I used the ^ sign because I am refering
     to myPointer's value *)
  Integer(myPointer^) := 2009;
  (* we are cleaning garbage from memory! *)
  FreeMem(myPointer, 4);
end;

Memory reallocation is very simple it takes two parameters the first is the pointer(in our case myPointer) and second the new size, i.e. ReallocMem(myPointer, 2);

The ZeroMemory procedure takes two parameters just like ReallocMem and clears value from memory, i.e. ZeroMemory(myPointer, 4(* or any other value, must not exceed the real size of the pointer! *));

MoveMemory basically moves a block of memory form one address to another, i.e. MoveMemory(myPointer, myDestinationPointer, 4);

CopyMemory the name should say everything is same as MoveMemory but instead of moving it just copies... example: CopyMemory(myPointer, mySourcePointer, 4); (* Caution: here the source and destination parameters are swapped! *)

FillMemory and FillChar are basically the same thing, FillMemory calls FillChar they both ask for the pointer(in our case myPointer) the length(the size of our pointer in memory, 4 in our case) and the byte value with which to fill, i.e. FillMemory(myPointer(* the pointer *), 4(* the size *), 255(* the value with which we fill the pointer, can be any value from 0 to 255 *));

FreeMem frees the allocated memory, it takes two parameters first the pointer(myPointer) and second the size(4), an example can be found up at the beginning along with AllocMem.
Warning according to Delphi help FreeMem should not be called directly.
Source: Delphi 7 Help
procedure FreeMem(var P: Pointer[; Size: Integer]);

In Delphi code, FreeMem destroys the variable referenced by P and returns its memory to the heap. If P does not point to memory in the heap, a runtime error occurs. If P points to a structure that includes long strings, variants, dynamic arrays, or interfaces, call Finalize before calling Freemem.
P is a variable of any pointer type previously assigned by the GetMem procedure.
Size specifies the size in bytes of the dynamic variable to dispose of; if specified, it must be exactly the number of bytes previously allocated to that variable by GetMem.
After calling FreeMem, the value of P is undefined.
Note: It is preferable to use the New and Dispose procedures rather than GetMem and FreeMem. When using New and Dispose, there is no need to explicitly call Finalize.

Monday, September 21, 2009

Multi-Language support update

Today I was reviewing the Blog and found out that that Multi-Language unit had a bug, screenshots also :), it's my fault I was in a hurry and didn't double-check the post, so here's the updated unit(small change to TRadioGroup implemention).
unit uDGLanguage;

interface

uses
  SysUtils,
  Classes,
  Forms,
  TypInfo,
  ExtCtrls;

const
  CCaption = 'Caption';

type
  TDGValue = record
    Hash: Integer;
    StringValue: String;
  end;

  TDGValueArray = array of TDGValue;

  TDGLanguage = class
  private
    FValues: TDGValueArray;
  private
    procedure AddEntry(thisEntry: TDGValue);
    procedure ClearArray;
  public
    function GetEntryValue(Hash: Integer; Default: String): String;
  public
    procedure SaveForm(thisForm: TForm);
    procedure LoadForm(thisForm: TForm);
  public
    procedure SaveLanguage(const FileName: String);
    procedure LoadLanguage(const FileName: String);
  public
    destructor Destroy; override;
  end;

implementation

(* Faster UpperCase *)

function TurboUpperCase(const Value: String): String;
var
  I: Integer;
  C: Char;
begin
  Result := Value;
  I := Length(Result);
  while I > 0 do begin
    C := Result[I];
    if c in [#97..#122] then
      Result[I] := Char(Ord(Result[I]) -32);
    Dec(I);
  end;
end;

(* Hash a string *)

function TurboHash(const theValue: string): Integer;
var
  I: Integer;
  Value: string;
begin
  Result := 0;
  Value := TurboUpperCase(theValue);
  for I := 1 to Length(Value) do
    Result := ((Result shl 7) or (Result shr 25)) + Ord(Value[I]);
end;

{ TDGLanguage }

procedure TDGLanguage.AddEntry(thisEntry: TDGValue);
var
  index: Integer;
begin
  (* Check if value exists *)
  for index := Low(FValues) to High(FValues) do
    if FValues[index].Hash = thisEntry.Hash then
      Exit;
  (* Add a new entry *)
  SetLength(FValues, Length(FValues) +1);
  FValues[High(FValues)] := thisEntry;
end;

destructor TDGLanguage.Destroy;
begin
  (* clear allocated memory *)
  ClearArray;
  FValues := nil;
end;

procedure TDGLanguage.LoadForm(thisForm: TForm);
var
  thisComponent: TComponent;
  Value,
  PreHash: String;
  Hash,
  index,
  RadioIndex: integer;
begin
  (* format a string for hash *)
  PreHash := Format('%s.%s', [thisForm.Name, thisForm.Name]);
  (* then hash it *)
  Hash := TurboHash(PreHash);
  (* get string value of the hash *)
  thisForm.Caption := GetEntryValue(Hash, thisForm.Caption);
  (* loop through all form components *)
  for index := 0 to thisForm.ComponentCount -1 do begin
    (* get component reference a.K.a. address *)
    thisComponent := thisForm.Components[Index];
    (* check if thisComponent has Caption property *)
    if IsPublishedProp(thisComponent, CCaption) then begin
      (* if it does then repeat the hash routine *)
      PreHash := Format('%s.%s', [thisForm.Name, thisComponent.Name]);
      Hash := TurboHash(PreHash);
      Value :=  GetPropValue(thisComponent, CCaption);
      (* get default value *)
      Value := GetEntryValue(Hash, Value);
      (* set value of the caption *)
      SetPropValue(thisComponent, CCaption, Value);
      (* check if it's radio group *)
      if thisComponent is TRadioGroup then begin
        for RadioIndex := 0 to TRadioGroup(thisComponent).Items.Count -1 do begin
          (* pre hash the item *)
          PreHash :=
            Format('%s.%s.%s',
              [thisForm.Name,
               thisComponent.Name,
               (* modified *)
               IntToStr(RadioIndex)]);
          (* now hash it *)
          Hash := TurboHash(PreHash);
          (* get default value *)
          Value := TRadioGroup(thisComponent).Items[RadioIndex];
          (* get value from array *)
          Value := GetEntryValue(Hash, Value);
          (* set new value to item *)
          TRadioGroup(thisComponent).Items[RadioIndex] := Value;
        end;
      end;
          (* else if thisComponent is TCustomType then begin ... *)
          (* this technique can be used for other components
          like VirtualTreeView, ListView's column headers, etc. *)
    end;
  end;
end;

procedure TDGLanguage.SaveForm(thisForm: TForm);
var
  thisComponent: TComponent;
  thisValue: TDGValue;
  PreHash: String;
  index,
  RadioIndex: integer;
begin
  PreHash := Format('%s.%s', [thisForm.Name, thisForm.Name]);
  thisValue.Hash := TurboHash(PreHash);
  thisValue.StringValue := thisForm.Caption;
  AddEntry(thisValue);
  for index := 0 to thisForm.ComponentCount -1 do begin
    thisComponent := thisForm.Components[Index];
    if IsPublishedProp(thisComponent, CCaption) then begin
      PreHash := Format('%s.%s', [thisForm.Name, thisComponent.Name]);
      thisValue.Hash := TurboHash(PreHash);
      thisValue.StringValue := GetPropValue(thisComponent, CCaption);
      (* add an entry to FValues array *)
      AddEntry(thisValue);
      if thisComponent is TRadioGroup then begin
        for RadioIndex := 0 to TRadioGroup(thisComponent).Items.Count -1 do begin
          (* pre hash the item *)
          PreHash :=
            Format('%s.%s.%s',
              [thisForm.Name,
               thisComponent.Name,
               (* modified *)
               IntToStr(RadioIndex)]);
          (* now hash it *)
          thisValue.Hash := TurboHash(PreHash);
          (* get default value *)
          thisValue.StringValue := TRadioGroup(thisComponent).Items[RadioIndex];
          (* get value from array *)
          AddEntry(thisValue);
        end;
      end;(* else if thisComponent is TCustomType then begin ... *)
          (* this technique can be used for other components
          like VirtualTreeView, ListView's column headers, etc. *)
    end;
  end;
end;

function TDGLanguage.GetEntryValue(Hash: Integer; Default: String): String;
var
  index: Integer;
begin
  (* check if hash exists in array *)
  for index := Low(FValues) to High(FValues) do
    (* if it does then *)
    if FValues[index].Hash = Hash then
      (* check if value is not Empty *)
      if FValues[index].StringValue <> '' then begin
        (* return the string value *)
        Result := FValues[index].StringValue;
        Exit;
      end;
  (* blah, no value in the array, return the Default parameter *)
  Result := Default;
end;

procedure TDGLanguage.LoadLanguage(const FileName: String);
var
  List: TStringList;
  index: Integer;
  thisValue: TDGValue;
  s: String;
begin
  (* clear array, we insert new values *)
  ClearArray;
  List := TStringList.Create;
  (* load language file to a TStringList *)
  List.LoadFromFile(FileName);
  (* loop through all lines *)
  (* lines saved as HashValue=StringValue *)
  for index := 0 to List.Count -1 do begin
    (* store line at index pos to "s" variable *)
    s := List[index];
    (* get it's hash value *)
    thisValue.Hash := StrToInt(copy(s, 1, Pos('=', s) -1));
    (* get it's string value *)
    thisValue.StringValue := copy(s, Pos('=', s) +1, MaxInt);
    (* add this entry to FValues array *)
    AddEntry(thisValue);
  end;
  (* clear allocated memory *)
  FreeAndNil(List);
end;

procedure TDGLanguage.SaveLanguage(const FileName: String);
var
  List: TStringList;
  index: Integer;
  thisValue: TDGValue;
  StringValue: String;
begin
  List := TStringList.Create;
  (* loop through all FValues entries *)
  for index := Low(FValues) to High(FValues) do begin
    (* store local *)
    thisValue := FValues[index];
    (* store the string representation of the entry *)
    StringValue := Format('%d=%s', [thisValue.Hash, thisValue.StringValue]);
    (* then add it to the string list *)
    List.Add(StringValue);
  end;
  (* save it to file *)
  List.SaveToFile(FileName);
  (* clear allocated memory *)
  FreeAndNil(List);
end;

procedure TDGLanguage.ClearArray;
begin
  SetLength(FValues, 0);
end;

end.

I've also updated screen shots and downloads, however you can download demo application and/or source code from this page as well.
If you have any suggestions or ideas do not hesitate to comment here.

Sunday, September 20, 2009

TIP: How to find a class definition

Did you ever find new classes(that you never knew) when you define a variable?
...
var
 yourVariable: (* here's where you press Ctrl+Space *);
...

Let's say you wish to declare yourVariable as TStream, but you also see TStreamAdapter in Code Completion hit enter, to see it's definition just hold Ctrl key down and click on the variable type in our case TStreamAdapter or TStream, IDE will take you to the unit and line where the class is defined.

If you press F1(the Help key in most applications) anywhere in Delphi IDE it will give you help information, for example if you click a class type in the code editor let's say TStream, the help file will provide information on TStream class, if you click the Object Inspector and hit F1 you will get information about it and so on.

Stream classes

This post is about Delphi Stream classes, if you continue reading it there's a chance you will find out new things about them.
Let's start with the base stream class which is TStream and it's defined as
  TStream = class(TObject)
  private
    function GetPosition: Int64;
    procedure SetPosition(const Pos: Int64);
    procedure SetSize64(const NewSize: Int64);
  protected
    function GetSize: Int64; virtual;
    procedure SetSize(NewSize: Longint); overload; virtual;
    procedure SetSize(const NewSize: Int64); overload; virtual;
  public
    function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
    function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
    function Seek(Offset: Longint; Origin: Word): Longint; overload; virtual;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; virtual;
    procedure ReadBuffer(var Buffer; Count: Longint);
    procedure WriteBuffer(const Buffer; Count: Longint);
    function CopyFrom(Source: TStream; Count: Int64): Int64;
    function ReadComponent(Instance: TComponent): TComponent;
    function ReadComponentRes(Instance: TComponent): TComponent;
    procedure WriteComponent(Instance: TComponent);
    procedure WriteComponentRes(const ResName: string; Instance: TComponent);
    procedure WriteDescendent(Instance, Ancestor: TComponent);
    procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
    procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
    procedure FixupResourceHeader(FixupInfo: Integer);
    procedure ReadResHeader;
    property Position: Int64 read GetPosition write SetPosition;
    property Size: Int64 read GetSize write SetSize64;
  end;

as you can see TStream's definition it is a abstract class, any class derived from TStream can be passed as parameter in a function call like
procedure DoSomething(Stream: TStream);
 ...

you can pass a TMemoryStream, TFileStream or any class variable which is derived from it.
Any class which is derived from TStream must override the abstract procedures and functions.

TFileStream class is derived from THandleStream(which is derived from TStream), it's defined as
{ THandleStream abstract class }

  THandleStream = class(TStream)
  protected
    FHandle: Integer;
    procedure SetSize(NewSize: Longint); override;
    procedure SetSize(const NewSize: Int64); override;
  public
    constructor Create(AHandle: Integer);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    property Handle: Integer read FHandle;
  end;

{ TFileStream class }

  TFileStream = class(THandleStream)
  public
    constructor Create(const FileName: string; Mode: Word); overload;
    constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload;
    destructor Destroy; override;
  end;

Note: Any class derived from TStream class or a class which is derived from TStream must override the Read, Write, Seek and SetSize methods so it can manipulate data and/or implement new methods/properties.
An example on TFileStream usage can be found at this post.

TMemoryStream class is useful for writing blocks of data in memory so you have faster access to it then you would if you where using a TFileStream.

A TStringStream class usage example can be found on this post.

TResourceStream description(Delphi 7 help)
Use TResourceStream to read the resources of an application. An instance of TResourceStream holds the value of a single resource in a memory buffer where it is accessible to the application.
The global ReadComponentRes function uses TResourceStream to access the compiled resources used by the application.

TWinSocketStream description(Delphi 7 Help)
Use TWinSocketStream to read or write information over a blocking socket connection. Windows socket objects include methods to read from or write to the socket connection they represent. However, these methods do not provide a mechanism for timing out when the socket connection is dropped or for waiting until the socket connection is ready before reading.

When the socket is a non-blocking socket, this lack of a time-out or waiting mechanism is not a problem, because reading and writing occur asynchronously in response to notifications from the socket connection. For blocking sockets, however, these mechanisms provided by TWinSocketStream are necessary so that the application using the socket does not hang indefinitely.
To use a Windows socket stream, create an instance of TWinSocketStream, use the methods of the stream to read or write the data, and then free the Windows socket stream.
Note: TWinSocketStream does not work with non-blocking sockets.
An alternative to TWinSocketStream is Primoz Gabrijelcic's TSafeWinSocketStream class that can be downloaded from this link.

Example of using TWinSocketStream
procedure TheClientThread.Execute;
var
  TheStream: TWinSocketStream;
  Buffer: string;
begin
  (* create a TWinSocketStream for reading and writing *)
  TheStream := TWinSocketStream.Create(ClientSocket1.Socket, 60000);
  try
    (* fetch and process commands until the connection or thread is terminated *)
    while (not Terminated) and (ClientSocket1.Active) do begin
      try
        (* GetNextRequest must be a thread-safe method *)
        GetNextRequest(Buffer);
        (* write the request to the server *)
        TheStream.Write(Buffer, Length(Buffer) + 1);
        (* continue the communication (eg read a response from the server) *)
        (* ... *)
      except
        if not(ExceptObject is EAbort) then
          (* you must write HandleThreadException *)
          Synchronize(HandleThreadException);
      end;
    end;
  finally
   TheStream.free;
  end;
end;

Saturday, September 19, 2009

Freeware Icon and Cursor editor

If you're looking for a icon and/or cursor editor look no further, I found the best freeware on the web.
The Icon Editor(IcoFX) and Cursor Editor(AniFX) are created by Attila Kovrig.

IcoFX



Homepage http://icofx.ro/

Features of IcoFX as presented on web page
-Support for Vista icons with PNG compression
-Create icons for Windows 98/ME/2000/XP/Vista/Macintosh
-Support for alpha channel (transparency)
-Batch processing for handling multiple files
-Built in resource editor for creating icon libraries or changing icons inside exe files
-Zoom icons up to 10000% for increased precision
-Import image dialog, for creating icons from images
-Convert Macintosh icons to Windows icons and vice versa
-Open, save, edit and convert Macintosh OS X icons
-Extract Macintosh icons from resource files
-Snapshot window for creating overviews of the icons
-More than 40 built in effects, including Drop Shadow
-Use custom filters to create your own customized effects
-Multiple language support
-Resolutions up to 256x256
-Data types: 2, 16, 256, True Color, True Color + Alpha (optional dithering for 2, 16, 256 colors)
-Extract icons (including Vista icons) from 32 bit exe and dll
-Import/export images (transparency also) from bmp, jpg, gif, png, jp2
-Many useful drawing tools like brush, line, rectangle and more
-Transparent, Brighten/Darken, Blur/Sharpen tools for retouching
-Create icon from an image with a single click
-Adjust the contrast, brightness, hue, saturation, transparency and color balance of icons
-Change the dimension of images
-Images can be faded using the fadeout dialog
-Increase/decrease the opacity of an image
-Easy shadow handling
-RGB and HSB color modes
-History of recently opened files
-Window menu for easy window switching
-Possibility to store favorite colors
-Capture image from the desktop
-Grid for precision work
-Side bar for easy image switching
-File Explorer window for easy file browsing and importing
-Full drag and drop support
-Sizable preview window
-Multiple undo
-Blur the edge of the brush
-Rotate the image at any angle

AniFX



Homepage http://icofx.ro/anifx/index.html

Features of AniFX as presented on web page
-Create cursors for Windows 98/ME/2000/XP/Vista
-Support for animated (ANI) cursors
-Support for alpha channel (transparency)
-Create animated GIF files
-Create toolbar images
-Batch processing for handling multipple files
-Built in resource editor for creating cursor libraries or changing cursors inside -exe files
-Zoom cursors up to 10000% for increased precision
-Import image dialog, for creating cursors from images
-Convert GIF files to animated cursors and vice versa
-Snapshot window for creating overviews of the cursors
-More than 40 built in effects, including Drop Shadow
-Use custom filters to create your own customized effects
-Multiple language support
-Resolutions up to 256x256
-Data types: 2, 16, 256, True Color, True Color + Alpha (optional dithering for 2, 16, 256 colors)
-Extract cursors (including Vista cursors) from 32 bit exe and dll
-Import/export images (transparency also) from bmp, jpg, gif, png, jp2
-Many useful drawing tools like brush, line, rectangle and more
-Transparent, Brighten/Darken, Blur/Sharpen tools for retouching
-Create cursor from an image with a single click
-Adjust the contrast, brightness, hue, saturation, transparency and color balance of cursors
-Change the dimension of images
-Images can be faded using the fadeout dialog
-Increase/decrease the opacity of an image
-Easy shadow handling
-RGB and HSB color modes
-History of recently opened files
-Window menu for easy window switching
-Possibility to store favorite colors
-Capture image from the desktop
-Grid for precision work
-Side bar for easy image switching
-File Explorer window for easy file browsing and importing
-Full drag and drop support
-Sizable preview window
-Multiple undo
-Blur the edge of the brush
-Rotate the image at any angle

Just in case hes website has any problems when you wish to download you can get them from this links IcoFX and/or AniFX, I check for updates once per month.
Note I zipped them because I'm not allowed to upload ".exe" files.
P.S. If you really like IcoFX and/or AniFX and you wish to show your appreciation, please donate to the author, he invested a lot of time and give it away for free.

Friday, September 18, 2009

Implementing a custom loop

I love C#/C++/Java for loop, it let's you define the value by which you increment the loop variable
 for (int index = 0; index <= 1000; index += 2)
Delphi does not have an equal loop, you can use a while/repeat loop and implement something similar, anyways here's my trial Create a new VCL application, drop a button and a spin edit on the form, define a new type like so
type
  TurboLoopCallback = procedure (Index: Integer) of Object;
now the loop procedure
procedure TurboLoop(
  Index, (* loop start index *)
  ToIndex: Integer; (* until this value *)
  Callback: TurboLoopCallback; (* the callback procedure *)
  const Step: Integer = 2); (* the step value *)
begin
  (* is it a TO or DOWNTO loop? *)
  if Index > ToIndex then begin
    (* this is a DOWNTO loop
      for index := VALUE downto VALUE do... *)
    while Index >= ToIndex do begin
      (* callback procedure *)
      Callback(Index);
      (* decrement the value of index by STEP value *)
      Dec(Index, Step);
    end;
  end else begin
    (* this is a TO loop *)
    while Index <= ToIndex do begin
      (* callback procedure *)
      Callback(Index);
      (* increment the value of index by STEP value *)
      Inc(Index, Step);
    end;
  end;
  (* tadam! that's it *)
end;
add a new public procedure to form
...
  public
    procedure MessageLoop(Index: Integer);
  end;
...
it's implemention
procedure TForm1.MessageLoop(Index: Integer);
begin
  ShowMessageFmt('this is my %d message', [Index]);
end;
and finally on button's OnClick event write this code
procedure TForm1.Button1Click(Sender: TObject);
begin
  TurboLoop(1, 10, MessageLoop, seIndex.Value);
end;
This is just a proof of concept, it is not very productive,

Thursday, September 17, 2009

How to copy a file and display it's progress

This is just a demo, it can be modified to copy files using thread(s) and display the progress in a separate window(like Total Commander does).
procedure TurboCopyFile(
  const
    SourceFile, (* the source file *)
    DestinationFile: String; (* destination file *)
  Display: PProgressbar (* this is a pointer to progress bar
    which we update if assigned,
    this procedure can be called without a
    progress bar like so:
    TurboCopyFile(Source, Destination, NIL); *)
  );
type
  (* define an array of 4096 bytes which holds the bytes *)
  TurboBuffer = array[1..4096] of Byte;
const
  (* we need to set the size of the buffer in a constant *)
  szBuffer = sizeof(TurboBuffer);
var
  (* File streams with which we work *)
  InStream,
  OutStream: TFileStream;
  (* we need this to store a logical operation's result *)
  CanCopy: Boolean;
  (* holds the number of bytes left when
     InStream.Size -InStream.Position < 4096 bytes *)
  BytesLeft: Integer;
  (* the Buffer almighty *)
  Buffer: TurboBuffer;
begin
  (* Open the source file so we can read it's bytes *)
  InStream := TFileStream.Create(SourceFile, fmOpenRead);
  (* create a new file to the desired destination *)
  OutStream := TFileStream.Create(DestinationFile, fmCreate);

  (* check if a progress bar was passed *)
  if Assigned(Display) then
    Display^.Max := InStream.Size;

  (* this is the operation I was talking about in the
     variable section, this checks if we can read a
     full buffer(4096 bytes) *)
  CanCopy :=
    (InStream.Size > InStream.Position) and
    ((InStream.Size -InStream.Position) >= szBuffer);

  (* this ensures that the progress bar is being painted *)
  Application.ProcessMessages;

  (* loop while we CanCopy *)
  while CanCopy do begin
    (* read 4096 bytes from source file *)
    InStream.ReadBuffer(Buffer, szBuffer);
    (* then write it to destination file *)
    OutStream.WriteBuffer(Buffer, szBuffer);
    (* check if display is assigned *)
    if Assigned(Display) then
      (* update it's position *)
      Display^.Position := InStream.Position;
    CanCopy :=
      (InStream.Size > InStream.Position) and
      ((InStream.Size -InStream.Position) >= szBuffer);
  end;

  (* store the number of bytes that is less than 4096 into
     a local variable *)
  BytesLeft := InStream.Size -InStream.Position;

  (* do we have some bytes left ? we don't care how many,
     we just know it's less than 4096 bytes *)
  if BytesLeft > 0 then begin
    (* surprise, or not we have some bytes left,
       read them all into the buffer *)
    InStream.ReadBuffer(Buffer, BytesLeft);
    (* write them to destination file *)
    OutStream.WriteBuffer(Buffer, BytesLeft);
  end;

  (* do we have a progress bar ? *)
  if Assigned(Display) then
    (* we do? then update it's progress *)
    Display^.Position := Display^.Max;

  (* free the memory *)
  FreeAndNil(InStream);
  FreeAndNil(OutStream);
end; (* end of TurboCopyFile *)

A demo application can be downloaded as
binary
or
sourcecode.

Tuesday, September 15, 2009

Text encryption with XOR

Ever wanted to encrypt a text message?
In order to do that we need some helper functions like transforming the string to it's hex representation after encryption so we don't loose any characters plus it looks very good:
function StringToHexStr(const value: string): string;
begin
  SetLength(Result, Length(value) *2);
  if Length(value) > 0 then
    BinToHex(PChar(value), PChar(Result), Length(value));
end;

function HexStrToString(const value: string): string;
begin
  SetLength(Result, Length(value) div 2);
  if Length(value) > 0 then
    HexToBin(PChar(value), PChar(Result), Length(value));
end;

ok... now we need a hash function so we hash our password string
function hashKey(const Key: String): Integer;
var
  Index: Integer;
begin
  Result := 0;;
  for Index := 1 to Length(Key) do
    Result := ((Result shl 7) or (Result shr 25)) + Ord(Key[Index]);
end;

Note that you can use any hash functions you like as long as it's result type is Cardinal or Integer(unsigned long or signed long) this hash function is taken from (RemObjects Software) PascalScript's "uPSUtils.pas" unit, now we need the algorithm
function __encrypt(const Key, Source: String): String;
// this function should not be used directly
// use EncryptText and DecryptText
const
  szBuffer = SizeOf(Integer); (* 4 bytes *)
  szByteBuffer = SizeOf(Byte); (* 1 byte *)
var
  byteBuffer,
  buffer,
  index,
  theKey: Integer;
  StreamOut,
  StreamIn: TStringStream;
begin
  (* hash the key and store it on local integer variable *)
  theKey := hashKey(Key);
  (* create two TStringStream's:
     - one for the actual data
     - the other one for the encrypted/decrypted data *)
  StreamIn := TStringStream.Create(Source);
  StreamOut := TStringStream.Create('');
  (* make sure position is set to ZERO !! *)
  StreamIn.Position := 0;
  StreamOut.Position := 0;

  (* now loop WHILE number of bytes read is less than
     number of total bytes AND the difference between
     position and size is greater or equal to szBuffer
     which is 4 bytes *)
  while (StreamIn.Position < StreamIn.Size) and
    ((StreamIn.Size -StreamIn.Position) >= szBuffer) do begin
    (* read 4 bytes at a time into a local integer variable *)
    StreamIn.ReadBuffer(buffer, szBuffer);
    (* the XOR encryption/decryption *)
    buffer := buffer xor theKey;
    buffer := buffer xor $E0F;
    (* write data to output stream *)
    StreamOut.WriteBuffer(buffer, szBuffer);
  end;

  (* check if we have some bytes left, there's a fat
     chance we do... *)
  if (StreamIn.Size -StreamIn.Position) >= 1 then
    for index := StreamIn.Position to StreamIn.Size -1 do begin
      (* we should have 1, 2 or 3 bytes left MAX, so we
         read 1 byte at a time *)
      StreamIn.ReadBuffer(byteBuffer, szByteBuffer);
      (* the XOR encryption/decryption *)
      byteBuffer := byteBuffer xor $F;
      (* write data to output stream *)
      StreamOut.WriteBuffer(byteBuffer, szByteBuffer);
    end;

  (* set output stream's postion to ZERO so we can
     read it's data *)
  StreamOut.Position := 0;
  (* read data from output stream and return it's value *)
  Result := StreamOut.ReadString(StreamOut.Size);

  (* free allocated memory *)
  FreeAndNil(StreamIn);
  FreeAndNil(StreamOut);
end;

the encryption and decryption functions
(* this function should be used ONLY for encryption *)
function EncryptText(const Key, Source: String): String;
begin
  (* return the encrypted data *)
  Result := __encrypt(Key, Source);
  (* convert string to hex string *)
  Result := StringToHexStr(Result);
end;

(* this function should be used ONLY for decryption *)
function DecryptText(const Key, Source: String): String;
begin
  (* convert each hex string to string *)
  Result := HexStrToString(Source);
  (* return the decrypted data *)
  Result := __encrypt(Key, Result);
end;

Here's the encryption result of string "http://delphigeist.blogspot.com"

124CE8194017B30D1F54EC01135FF900094CB20B1657FB1A0A57E8476C6062


using "delphigeist" as password.
Note that when you press Encrypt button the Text box is used as source and Encrypted box as output and vice-versa.
Screenshot of demo application taken with TurboSS

Demo application can be downloaded as:
binary
or
source code
I really hope this helps you in any way, even as a toy :).
P.S. the StringToHexStr and HexStrToString function are taken from Delphi PRAXIS the guy that posted is called "EDatabaseError", I'm too lazy...

Saturday, September 12, 2009

Shutup Windows Firewall

When you start a HTTP or TCP server and you have Windows Firewall active you've noticed that a window will appear "Windows Security Alert" if your customer doesn't have too much Windows knowledge then he freaks out "What is that, do I have a virus, your program doesn't work!".
Here's something to bypass this warning:
 - Put a TTimer on a form
 - OnTimer event Copy-Paste this code
const
  CWINDOWSECURITYALER = 'Windows Security Alert';
  CBTNUNLOCK = 'Unblock';
var
  hwndAlert: HWND;
begin
  hwndAlert := FindWindow(nil, CWINDOWSECURITYALER);
  if hwndAlert <> 0 then
    WindowBtnClick(hwndAlert, CBTNUNLOCK);
end;

You can get WindowBtnClick procedure code from my older post Click a window's button.
Change timer's interval to 200 or 500.
Before starting a server or anything that triggers a "Windows Security Alert" window enable timer and after that disable it.
Tested only under Windows XP, should/might work under Windows Vista and/or Windows 7, please let me know if you test this under any other OS version than XP.

Need lighter or darker Color?

Simple functions to get lighter or darker value of a TColor a.K.a. Integer
(* darker color of thisColor by thePercent value *)
function DarkerColor(thisColor: TColor; thePercent: Byte): TColor;
var
  (* a TColor is made out of Red, Green and blue *)
  cRed,
  cGreen,
  cBlue: Byte;
begin
  (* get them individually *)
  cRed := GetRValue(thisColor);
  cGreen := GetGValue(thisColor);
  cBlue := GetBValue(thisColor);
  (* make them darker thePercent *)
  (* we need a byte value but the "/" operator
     returns a float value so we use Round function
     because type mismatch *)
  cRed := Round(cRed * thePercent / 100);
  cGreen := Round(cGreen * thePercent / 100);
  cBlue := Round(cBlue * thePercent / 100);
  (* return them as TColor *)
  Result := RGB(cRed, cGreen, cBlue);
end;

(* lighter color of thisColor by thePercent value *)
function LighterColor(thisColor: TColor; thePercent: Byte): TColor;
var
  cRed,
  cGreen,
  cBlue: Byte;
begin
  cRed := GetRValue(thisColor);
  cGreen := GetGValue(thisColor);
  cBlue := GetBValue(thisColor);
  (* a byte's range is from 0 to 255
     so Red, Green and Blue can have
     a value between 0 and 255 *)
  cRed :=
    Round(cRed * thePercent / 100) +
    Round(255 - thePercent / 100 * 255);
  cGreen :=
    Round(cGreen * thePercent / 100) +
    Round(255 - thePercent / 100 * 255);
  cBlue :=
    Round(cBlue * thePercent / 100) +
    Round(255 - thePercent / 100 * 255);
  Result := RGB(cRed, cGreen, cBlue);
end;

Usage
 aColor := DarkerColor(clRed, 15{percent});
 aColor := LighterColor(clBlack, 80{percent});

How to draw text on Screen

Need to draw text or graphic on screen?
Here's how to do it:
 - File -> New -> Application
 - Put a button anywhere on the form
 - Double-click the button and Copy-Paste this code
procedure TForm1.Button1Click(Sender: TObject);
(* our text *)
const
  CTHE_TEXT = 'I Love Delphigeist';
(* we need a canvas object *)
var
  theCanvas: TCanvas;
begin
  (* create theCanvas *)
  theCanvas := TCanvas.Create;
  (* get Desktop canvas handle *)
  theCanvas.Handle := GetWindowDC(0);
  (* we don't want a rectangle behind our text
     this is optional you can comment next line with "//"
     and see how it looks *)
  theCanvas.Brush.Style := bsClear;
  (* set the font name *)
  theCanvas.Font.Name := 'Courier New';
  (* we want it bold *)
  theCanvas.Font.Style := [fsBold];
  (* set the size *)
  theCanvas.Font.Size := 60;
  (* lime look good if your wallpaper has dark colors *)
  theCanvas.Font.Color := clLime;
  (* draw the text *)
  theCanvas.TextOut(50, 50, CTHE_TEXT);
  (* clear allocated memory to our theCanvas object *)
  FreeAndNil(theCanvas);
  (* that's it *)
end;

Now if you want to draw a TBitmap or TJPEGImage on Desktop then replace
  theCanvas.TextOut(50, 50, CTHE_TEXT);
with
  theCanvas.Draw(50, 50, thisBitmap{or thisJpegImage});
Note
You must initialize the variable first and load an image to it!

Friday, September 11, 2009

Blur bitmap algorithm

Some time ago I needed a bitmap blur algorithm and found this(I'm not the author, but I did modified a bit)
procedure BitmapBlur(var theBitmap: TBitmap);
var
  x, y: Integer;
  yLine,
  xLine: PByteArray;
begin
  for y := 1 to theBitmap.Height -2 do begin
    yLine := theBitmap.ScanLine[y -1];
    xLine := theBitmap.ScanLine[y];
    for x := 1 to theBitmap.Width -2 do begin
      xLine^[x * 3] := (
        xLine^[x * 3 -3] + xLine^[x * 3 +3] +
        yLine^[x * 3 -3] + yLine^[x * 3 +3] +
        yLine^[x * 3] + xLine^[x * 3 -3] +
        xLine^[x * 3 +3] + xLine^[x * 3]) div 8;
      xLine^[x * 3 +1] := (
        xLine^[x * 3 -2] + xLine^[x * 3 +4] +
        yLine^[x * 3 -2] + yLine^[x * 3 +4] +
        yLine^[x * 3 +1] + xLine^[x * 3 -2] +
        xLine^[x * 3 +4] + xLine^[x * 3 +1]) div 8;
      xLine^[x * 3 +2] := (
        xLine^[x * 3 -1] + xLine^[x * 3 +5] +
        yLine^[x * 3 -1] + yLine^[x * 3 +5] +
        yLine^[x * 3 +2] + xLine^[x * 3 -1] +
        xLine^[x * 3 +5] + xLine^[x * 3 +2]) div 8;
    end;
  end;
end;

Usage
...
var
  bmp: TBitmap;
begin
  bmp := Image1.Picture.Bitmap;
  BitmapBlur(bmp);
  Image1.Picture.Bitmap := bmp;
end;

Multi-Language support

Did you ever needed to add language support to your application?
Delphi IDE provides a way to make your application Multi-Language via Main Menu -> Project -> Languages -> Add... but if your in a hurry here's a quick and dirty way to do it.
unit uDGLanguage;

interface

uses
  SysUtils,
  Classes,
  Forms,
  TypInfo,
  ExtCtrls;

const
  CCaption = 'Caption';

type
  TDGValue = record
    Hash: Integer;
    StringValue: String;
  end;

  TDGValueArray = array of TDGValue;

  TDGLanguage = class
  private
    FValues: TDGValueArray;
  private
    procedure AddEntry(thisEntry: TDGValue);
    procedure ClearArray;
  public
    function GetEntryValue(Hash: Integer; Default: String): String;
  public
    procedure SaveForm(thisForm: TForm);
    procedure LoadForm(thisForm: TForm);
  public
    procedure SaveLanguage(const FileName: String);
    procedure LoadLanguage(const FileName: String);
  public
    destructor Destroy; override;
  end;

implementation

uses IniFiles;

(* Faster UpperCase *)

function TurboUpperCase(const Value: String): String;
var
  I: Integer;
  C: Char;
begin
  Result := Value;
  I := Length(Result);
  while I > 0 do begin
    C := Result[I];
    if c in [#97..#122] then
      Result[I] := Char(Ord(Result[I]) -32);
    Dec(I);
  end;
end;

(* Hash a string *)

function TurboHash(const theValue: string): Integer;
var
  I: Integer;
  Value: string;
begin
  Result := 0;
  Value := TurboUpperCase(theValue);
  for I := 1 to Length(Value) do
    Result := ((Result shl 7) or (Result shr 25)) + Ord(Value[I]);
end;

{ TDGLanguage }

procedure TDGLanguage.AddEntry(thisEntry: TDGValue);
var
  index: Integer;
begin
  (* Check if value exists *)
  for index := Low(FValues) to High(FValues) do
    if FValues[index].Hash = thisEntry.Hash then
      Exit;
  (* Add a new entry *)
  SetLength(FValues, Length(FValues) +1);
  FValues[High(FValues)] := thisEntry;
end;

destructor TDGLanguage.Destroy;
begin
  (* clear allocated memory *)
  ClearArray;
  FValues := nil;
end;

procedure TDGLanguage.LoadForm(thisForm: TForm);
var
  thisComponent: TComponent;
  Value,
  PreHash: String;
  Hash,
  index,
  RadioIndex: integer;
begin
  (* format a string for hash *)
  PreHash := Format('%s.%s', [thisForm.Name, thisForm.Name]);
  (* then hash it *)
  Hash := TurboHash(PreHash);
  (* get string value of the hash *)
  thisForm.Caption := GetEntryValue(Hash, thisForm.Caption);
  (* loop through all form components *)
  for index := 0 to thisForm.ComponentCount -1 do begin
    (* get component reference a.K.a. address *)
    thisComponent := thisForm.Components[Index];
    (* check if thisComponent has Caption property *)
    if IsPublishedProp(thisComponent, CCaption) then begin
      (* if it does then repeat the hash routine *)
      PreHash := Format('%s.%s', [thisForm.Name, thisComponent.Name]);
      Hash := TurboHash(PreHash);
      Value :=  GetPropValue(thisComponent, CCaption);
      (* get default value *)
      Value := GetEntryValue(Hash, Value);
      (* set value of the caption *)
      SetPropValue(thisComponent, CCaption, Value);
      (* check if it's radio group *)
      if thisComponent is TRadioGroup then begin
        for RadioIndex := 0 to TRadioGroup(thisComponent).Items.Count -1 do begin
          (* pre hash the item *)
          PreHash :=
            Format('%s.%s.%s',
              [thisForm.Name,
               thisComponent.Name,
               TRadioGroup(thisComponent).Items[RadioIndex]]);
          (* now hash it *)
          Hash := TurboHash(PreHash);
          (* get default value *)
          Value := TRadioGroup(thisComponent).Items[RadioIndex];
          (* get value from array *)
          Value := GetEntryValue(Hash, Value);
          (* set new value to item *)
          TRadioGroup(thisComponent).Items[RadioIndex] := Value;
        end;
      end;(* else if thisComponent is TCustomType then begin ... *)
          (* this technique can be used for other components
          like VirtualTreeView, ListView's column headers, etc. *)
    end;
  end;
end;

procedure TDGLanguage.SaveForm(thisForm: TForm);
var
  thisComponent: TComponent;
  thisValue: TDGValue;
  PreHash: String;
  index,
  RadioIndex: integer;
begin
  PreHash := Format('%s.%s', [thisForm.Name, thisForm.Name]);
  thisValue.Hash := TurboHash(PreHash);
  thisValue.StringValue := thisForm.Caption;
  AddEntry(thisValue);
  for index := 0 to thisForm.ComponentCount -1 do begin
    thisComponent := thisForm.Components[Index];
    if IsPublishedProp(thisComponent, CCaption) then begin
      PreHash := Format('%s.%s', [thisForm.Name, thisComponent.Name]);
      thisValue.Hash := TurboHash(PreHash);
      thisValue.StringValue := GetPropValue(thisComponent, CCaption);
      (* add an entry to FValues array *)
      AddEntry(thisValue);
      if thisComponent is TRadioGroup then begin
        for RadioIndex := 0 to TRadioGroup(thisComponent).Items.Count -1 do begin
          (* pre hash the item *)
          PreHash :=
            Format('%s.%s.%s',
              [thisForm.Name,
               thisComponent.Name,
               TRadioGroup(thisComponent).Items[RadioIndex]]);
          (* now hash it *)
          thisValue.Hash := TurboHash(PreHash);
          (* get default value *)
          thisValue.StringValue := TRadioGroup(thisComponent).Items[RadioIndex];
          (* get value from array *)
          AddEntry(thisValue);
        end;
      end;(* else if thisComponent is TCustomType then begin ... *)
          (* this technique can be used for other components
          like VirtualTreeView, ListView's column headers, etc. *)
    end;
  end;
end;

function TDGLanguage.GetEntryValue(Hash: Integer; Default: String): String;
var
  index: Integer;
begin
  (* check if hash exists in array *)
  for index := Low(FValues) to High(FValues) do
    (* if it does then *)
    if FValues[index].Hash = Hash then
      (* check if value is not Empty *)
      if FValues[index].StringValue <> '' then begin
        (* return the string value *)
        Result := FValues[index].StringValue;
        Exit;
      end;
  (* blah, no value in the array, return the Default parameter *)
  Result := Default;
end;

procedure TDGLanguage.LoadLanguage(const FileName: String);
var
  List: TStringList;
  index: Integer;
  thisValue: TDGValue;
  s: String;
begin
  (* clear array, we insert new values *)
  ClearArray;
  List := TStringList.Create;
  (* load language file to a TStringList *)
  List.LoadFromFile(FileName);
  (* loop through all lines *)
  (* lines saved as HashValue=StringValue *)
  for index := 0 to List.Count -1 do begin
    (* store line at index pos to "s" variable *)
    s := List[index];
    (* get it's hash value *)
    thisValue.Hash := StrToInt(copy(s, 1, Pos('=', s) -1));
    (* get it's string value *)
    thisValue.StringValue := copy(s, Pos('=', s) +1, MaxInt);
    (* add this entry to FValues array *)
    AddEntry(thisValue);
  end;
  (* clear allocated memory *)
  FreeAndNil(List);
end;

procedure TDGLanguage.SaveLanguage(const FileName: String);
var
  List: TStringList;
  index: Integer;
  thisValue: TDGValue;
  StringValue: String;
begin
  List := TStringList.Create;
  (* loop through all FValues entries *)
  for index := Low(FValues) to High(FValues) do begin
    (* store local *)
    thisValue := FValues[index];
    (* store the string representation of the entry *)
    StringValue := Format('%d=%s', [thisValue.Hash, thisValue.StringValue]);
    (* then add it to the string list *)
    List.Add(StringValue);
  end;
  (* save it to file *)
  List.SaveToFile(FileName);
  (* clear allocated memory *)
  FreeAndNil(List);
end;

procedure TDGLanguage.ClearArray;
begin
  SetLength(FValues, 0);
end;

end.

The above class solves a lot of hard-work and dedicated time, by the way you can use Google Translate for a quick translate, even though you should check if the translation is OK but that's another subject.
Here's a screenshot of a demo application with English translation loaded



and a screenshot with Romanian(my language) translation loaded



You can download demo application or source code(demo included but not compiled).

How to get all desktop windows

Need to get a list of all desktop visible windows?
Here's a function which does just that
procedure GetDesktopWindows(List: TStrings);
var
  hDesktop,
  hWindow: Hwnd;
  Buffer: array[0..255] of char;
begin
  hDesktop := GetDeskTopWindow;
  hWindow := GetWindow(hDesktop, GW_CHILD);
  while hWindow <> 0 do begin
    GetWindowText(hWindow, Buffer, 255);
    if (Buffer <> '') and (IsWindowVisible(hWindow) > False) then
      List.Add(Buffer);
    hWindow := GetWindow(hWindow, GW_HWNDNEXT);
  end;
end;

Usage
procedure TForm1.Button1Click(Sender: TObject);
var
  List: TStrings;
begin
  List := TStringList.Create;
  GetDesktopWindows(List);
  ShowMessage(List.Text);
  FreeAndNil(List);
end;

And you get this



SEE huh?

TurboSS

TurboSS is a application which takes screenshots when you press your custom hotkey.
I believe that it has every option you (might)need.
It can be used to take in-game screenshots when you can't press the "Print Screen" key and go to a image editor(i.e. Paint) or when you make a tutorial and need a screenshot of a window.
Here's a screenshot of TurboSS



Ummm... Yeah! the screenshot was taken with TurboSS.
In order to compile this application you need Hotkey Manager Component(author Troels Jakobsen), it can be downloaded from this link.
You can download TurboSS application or source code.

Thursday, September 10, 2009

Tray Icon anyone?

I'm not sure from what version of Delphi but Delphi 7 doesn't have a Tray Icon component, Cool Tray Icon is a very nice component I strongly recommend it.
I needed it few days ago and I was searching the Internet for an updated version, couldn't find one but I saw that Google results are way less than a few months ago, so I searched my HDD for a version of Cool Tray Icon and uploaded to my Google site, you can download Cool Tray Icon from this link.
The author of this wonderful component is Troels Jakobsen you can access hes website via this link.

Enable file drop on a control?

Now this is cool, want to enable drag and drop files in you application on a TPanel or TForm? Look no further here's a component which does just that(can't remember from where I found this)
unit uDGDropSite;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  ShellApi;

type
  TDGDropSite = class(TComponent)
  private
    FNameWithPath: TStrings;
    FNumDropped: Integer;
    FEnabled: Boolean;
    FWndHandle: HWND;
    FDefProc: Pointer;
    FWndProcInstance: Pointer;
    FOnDrop: TNotifyEvent;
    FDropPt: TPoint;
    FParentControl: TWinControl;
  private
    procedure DropFiles(hDropHandle: HDrop);
    procedure SetEnabled(Value: Boolean);
    procedure WndProc(var Msg: TMessage);
    procedure InitControl;
    procedure DestroyControl;
    procedure SetParentControl(Value : TWinControl);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Files: TStrings
      read FNameWithPath;
    property FileCount: Integer
      read FNumDropped;
    property DropPoint: TPoint
      read FDropPt;
    property EnableDrop: Boolean
      read FEnabled write SetEnabled;
    property DropControl: TWinControl
      read FParentControl write SetParentControl;
    property OnDrop: TNotifyEvent
      read FOnDrop write FOnDrop;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Delphigeist', [TDGDropSite]);
end;

constructor TDGDropSite.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FNumDropped := 0;
  FNameWithPath := TStringList.Create;
  if AOwner is TWinControl then 
    SetParentControl(AOwner as TWinControl) else
    FWndHandle := 0;
  FDropPt.X := 0;
  FDropPt.Y := 0;
end;

destructor TDGDropSite.Destroy;
begin
  DestroyControl;
  SetEnabled(False);
  FNameWithPath.Free;
  inherited Destroy;
end;

procedure TDGDropSite.InitControl;
var
  WinCtl: TWinControl;
begin
  if FParentControl is TWinControl then begin
    WinCtl := TWinControl(FParentControl);
    FWndHandle := WinCtl.Handle;
    FWndProcInstance := MakeObjectInstance(WndProc);
    FDefProc := Pointer(GetWindowLong(FWndHandle, GWL_WNDPROC));
    SetWindowLong(FWndHandle, GWL_WNDPROC, Longint(FWndProcInstance));
  end else
  FEnabled := False;
end;

procedure TDGDropSite.DestroyControl;
begin
  if FWndHandle <> 0 then begin
    SetWindowLong(FWndHandle, GWL_WNDPROC, Longint(FDefProc));
    FreeObjectInstance(FWndProcInstance);
  end
end;
procedure TDGDropSite.SetParentControl(Value: TWinControl);
begin
  if Value = nil then begin
    SetWindowLong(FWndHandle, GWL_WNDPROC, Longint(FDefProc));
    FreeObjectInstance(FWndProcInstance);
    SetEnabled(False);
    FParentControl := nil;
    Exit;
  end else
    if Value<>FParentControl then begin
      FParentControl := Value;
      InitControl;
      SetEnabled(True);
    end;
end;
procedure TDGDropSite.SetEnabled(Value: Boolean);
begin
  if FParentControl = nil then
    Exit;
  FEnabled := Value;
  DragAcceptFiles(FWndHandle, FEnabled);
end;

procedure TDGDropSite.DropFiles(hDropHandle: HDrop);
var
  pszFileWithPath: PChar;
  iFile, iStrLen, iTempLen: Integer;
begin
  iStrLen := 128;
  pszFileWithPath := StrAlloc(iStrLen);
  iFile := 0;
  FNameWithPath.Clear;
  FNumDropped := DragQueryFile(hDropHandle, $FFFFFFFF, nil, iStrLen);
  DragQueryPoint(hDropHandle, FDropPt);
  while (iFile < FNumDropped) do begin
    iTempLen := DragQueryFile(hDropHandle, iFile, nil, 0) + 1;
    if (iTempLen > iStrLen) then begin
      iStrLen := iTempLen;
      StrDispose(pszFileWithPath);
      pszFileWithPath := StrAlloc(iStrLen);
    end;
    DragQueryFile(hDropHandle, iFile, pszFileWithPath, iStrLen);
    FNameWithPath.Add(StrPas(pszFileWithPath));
    Inc(iFile);
  end;
  StrDispose(pszFileWithPath);
  if Assigned(FOnDrop) then
    FOnDrop(Self);
end;

procedure TDGDropSite.WndProc(var Msg: TMessage);
begin
  with Msg do begin
    if Msg = WM_DROPFILES then
      DropFiles(HDrop(wParam)) else
      Result := CallWindowProc(FDefProc, FWndHandle, Msg, WParam, LParam);
    end;
end;

end.

When you add it on a form it will automatically add the form as a "Drop Site" for files, OnDrop will be triggered when one or more files are dropped on a designated control.
If you need the install package of this component you can get it from this link.

Connected to Internet?

Sometimes you need to know if the computer on which your program is running has Internet connection in order to check for updates connect to a server and serve as slave :)
Add "WinInet" to uses clause.
function ConnectedToNet: boolean;
var
  flags: DWORD;
begin
  Flags :=
    INTERNET_CONNECTION_MODEM or
    INTERNET_CONNECTION_LAN or
    INTERNET_CONNECTION_PROXY or
    INTERNET_CONNECTION_MODEM_BUSY;
  result := InternetGetConnectedState(@Flags, 0);
end;

Usage
 ShowMessage(BoolToStr(ConnectedToNet, True));

Click a window's button?

Now this function is awesome I needed some time ago for a special program which clicks on "Unblock" button on "Windows Security Alert" window :)
Here's the code
function EnumChildProc(Wnd: hWnd; SL: TStrings): BOOL; stdcall;
var
  szFull: array[0..MAX_PATH] of Char;
begin
  Result := Wnd <> 0;
  if Result then begin
    GetWindowText(Wnd, szFull, SizeOf(szFull));
    if (Pos(SL[0], StrPas(szFull)) > 0) and
       (SL.IndexOfObject(TObject(Wnd)) < 0) then
      SL.AddObject(StrPas(szFull), TObject(Wnd));
    EnumChildWindows(Wnd, @EnumChildProc, Longint(SL));
  end;
end;

function WindowBtnClick(ParentWindow: Hwnd; ButtonCaption: string): Boolean;
var
  SL: TStringList;
  H:  hWnd;
begin
  SL := TStringList.Create;
  try
    SL.AddObject(ButtonCaption, nil);
    EnumChildWindows(ParentWindow, @EnumChildProc, Longint(SL));
    H := 0;
    case SL.Count of
      1: Exit;
      2: H := hWnd(SL.Objects[1]);
      else
        Exit;
    end;
  finally
    SL.Free;
  end;
  Result := H <> 0;
  if Result then
    PostMessage(H, BM_CLICK, 0, 0);
end;

Usage
procedure TForm1.Button1Click(Sender: TObject);
var
  hCalculator: HWND;
label
  tryAgain;
begin
  tryAgain:
    hCalculator := FindWindow(nil, 'Calculator');
    if hCalculator <> 0 then
      WindowBTNclick(hCalculator, '2') else begin
        WinExec('calc', SW_SHOW);
        Sleep(1500);
        goto tryAgain;
    end;
end;

You can change '2' with anyother key, i.e. '9', apparently '1' is not working, I don't know why... anyways have fun!

Get/Set Computer Name?

Need to get/set the computer name?

Get function
function GetPCName: string;
var
  buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
  Size: Cardinal;
begin
  Size := MAX_COMPUTERNAME_LENGTH + 1;
  Windows.GetComputerName(@buffer, Size);
  Result := StrPas(buffer);
end;

Set function
function SetPCName(AName: string): Boolean;
var
  PCName: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
  Size: Cardinal;
begin
  StrPCopy(PCName, AName);
  Result := Windows.SetComputerName(PCName);
end;

Invert a bitmap

How to invert a bitmap
function BitmapInvert(ABitmap: TBitmap): TBitmap;
var
  x, y: Integer;
  ByteArray: PByteArray;
begin
  ABitmap.PixelFormat := pf24Bit;
  for y := 0 to ABitmap.Height - 1 do begin
    ByteArray := ABitmap.ScanLine[y];
    for x := 0 to ABitmap.Width * 3 - 1 do begin
      ByteArray[x] := 255 -ByteArray[x];
    end;
  end;
  Result := ABitmap;
end;

Usage
 myBitmap := BitmapInvert(aBitmapVariable{or myBitmap});

Get CPU speed?

A few years ago I needed a function which retrieves the CPU speed, after a few hours on Google I found this function
function GetCPUSpeed: Integer;
const
 DelayTime = 500;
var
 TimerHi, TimerLo: DWORD;
 PriorityClass, Priority: Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);
  SetPriorityClass(GetCurrentProcess,REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
  Sleep(10);
  asm
    DW 310Fh // rdtsc
    MOV TimerLo, EAX
    MOV TimerHi, EDX
  end;
  Sleep(DelayTime);
  asm
    DW 310Fh // rdtsc
    SUB EAX, TimerLo
    SBB EDX, TimerHi
    MOV TimerLo, EAX
    MOV TimerHi, EDX
  end;
  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);
  Result := Round(TimerLo / (1000.0 * DelayTime));
end;

It's simply SEE :)

Take a screenshot?

Need to take a screenshot?
Here's the code
// get a desired rect screenshot //
procedure ScreenshotArea(
  var theBitmap: TBitmap;
  const thisArea: TRect;
  const IncludeCursor: Boolean = False);
const
  CDESKTOP_HWND = 0;
var
  hdcDesktop: HDC;
  theCursorInfo: TCursorInfo;
  theIcon: TIcon;
  theIconInfo: TIconInfo;
begin
  theBitmap.Width  := thisArea.Right -thisArea.Left;
  theBitmap.Height := thisArea.Bottom -thisArea.Top;
  hdcDesktop := GetWindowDC(CDESKTOP_HWND);
  BitBlt(
    theBitmap.Canvas.Handle,
    0,
    0,
    thisArea.Right,
    thisArea.Bottom,
    hdcDesktop,
    thisArea.Left,
    thisArea.Top,
    SRCCOPY);
  theBitmap.Modified := True;
  ReleaseDC(CDESKTOP_HWND, hdcDesktop);
  if IncludeCursor then begin  
    theIcon := TIcon.Create;
    try
      theCursorInfo.cbSize := SizeOf(theCursorInfo);
      if GetCursorInfo(theCursorInfo) then
        if theCursorInfo.flags = CURSOR_SHOWING then begin
          theIcon.Handle := CopyIcon(theCursorInfo.hCursor);
          if GetIconInfo(theIcon.Handle, theIconInfo) then
            try
              theBitmap.Canvas.Draw(
                theCursorInfo.ptScreenPos.x
                  -Integer(theIconInfo.xHotspot) -thisArea.Left,
                theCursorInfo.ptScreenPos.y
                  -Integer(theIconInfo.yHotspot) -thisArea.Top, theIcon);
            finally
              DeleteObject(theIconInfo.hbmMask);
              DeleteObject(theIconInfo.hbmColor);
            end;
        end;
    finally
      theIcon.Free;
    end;
  end;
end;

// take a screenshot of active window //
procedure ScreenshotActiveWindow(
  var theBitmap: TBitmap;
  const IncludeCursor: Boolean = True);
var
  WindowRect: TRect;
  hwndForegroundWindow: HWND;
begin
  hwndForegroundWindow := GetForegroundWindow;
  GetWindowRect(hwndForegroundWindow, WindowRect);
  ScreenshotArea(theBitmap, WindowRect, IncludeCursor);
end;

Usage
// example of taking active window's screenshot //
procedure TForm1.Button1Click(Sender: TObject);
var
  thisBitmap: TBitmap;
begin
  thisBitmap := TBitmap.Create;
  ScreenshotActiveWindow(thisbitmap, True);
  Image1.Picture.Assign(thisBitmap);
  FreeAndNil(thisBitmap);
end;

// example of taking full screenshot //

procedure TForm1.Button1Click(Sender: TObject);
var
  thisBitmap: TBitmap;
begin
  thisBitmap := TBitmap.Create;
  ScreenshotArea(thisBitmap, Screen.DesktopRect, True);
  Image1.Picture.Assign(thisBitmap);
  FreeAndNil(thisBitmap);
end;

Show/Hide Windows Desktop/Taskbar

Need to show/hide Windows Desktop/Taskbar?
procedure ShowTaskbar(T: Boolean);
var
  hTaskbar: HWND;
begin
  hTaskbar := FindWindow('Shell_TrayWnd', nil);
  if hTaskbar <> 0 then
    if T then
      ShowWindow(wndHandle, SW_SHOW or SW_RESTORE) else
      ShowWindow(wndHandle, SW_HIDE);
end;

Usage
 Show
  ShowTaskbar(True);
 Hide
  ShowTaskbar(False);
procedure ShowDesktop(T: Boolean);
var
  hDesktop: HWND;
begin
  hDesktop := FindWindow('progman', nil);
  if hDesktop <> 0 then
    if T then
      ShowWindow(hDesktop, SW_SHOW or SW_RESTORE) else
      ShowWindow(hDesktop, SW_HIDE);
end;

Usage
 Show
  ShowDesktop(True);
 Hide
  ShowDesktop(False);

How to scale bitmap in percent

Need to scale a bitmap to 50%? how about 128%?
Here's a function which scales a bitmap to desired percent
function BitmapScale(theBitmap: TBitmap; iPercent: Integer): Boolean;
var
  TmpBmp: TBitmap;
  ARect: TRect;
  h, w: Real;
  hi, wi: Integer;
begin
  Result := False;
  try
    TmpBmp := TBitmap.Create;
    try
      h := theBitmap.Height * (iPercent / 100);
      w := theBitmap.Width * (iPercent / 100);
      hi := StrToInt(FormatFloat('#', h)) + theBitmap.Height;
      wi := StrToInt(FormatFloat('#', w)) + theBitmap.Width;
      TmpBmp.Width := wi;
      TmpBmp.Height := hi;
      ARect := Rect(0, 0, wi, hi);
      TmpBmp.Canvas.StretchDraw(ARect, theBitmap);
      theBitmap.Assign(TmpBmp);
    finally
      TmpBmp.Free;
    end;
    Result := True;
  except
    Result := False;
  end;
end;


Usage
BitmapScale(YourBitmapVar, 70);

Register/Unregister startup application

Here's a nice function which register or unregister an application from startup registry key(add "Registry" to uses clause)
procedure WindowsAutoStartApp(AppPath, AppTitle: string; bRegister: Boolean);
const
  RegKey = '\Software\Microsoft\Windows\CurrentVersion\Run';
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create;
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    if Registry.OpenKey(RegKey, False) then
    begin
      if bRegister = False then
        Registry.DeleteValue(AppTitle)
      else
        Registry.WriteString(AppTitle, AppPath);
    end;
  finally
    Registry.Free;
  end;
end;

Usage
 Register
  WindowsAutoStartApp('C:\Windows\Notepad', 'Notepad', True);
 Unregister
  WindowsAutoStartApp('C:\Windows\Notepad', 'Notepad', False);

Delphi Distiller





If you don't know about Delphi Distiller then it's time for you to know.
Delphi Distiller is a tool that can bypass Delphi CodeGear/Embarcadero license check.
This is the main window



It automatically switch to the lowest Delphi version you have installed on system, ok so no harm from what you can see, now PRESS CTRL+ALT+L and you'll get this



Did you notice the new tab "Secret Stuff"?
Well you can check it out, it can remove Delphi 2010, Delphi 2009, Delphi 2007 and Delphi 2006 license, it also has some tweaks to start IDE a bit faster.
Delphi Distiller can be located at home page fallowing this link.
If you remove license check you don't need Delphi *.slip file or anything else, just the time to test the IDE.

Blogroll(General programming and Delphi feeds)