ICS V8.67 adds Delphi 11 and OpenSSL 3 support

ICS V8.67 has been released at: http://wiki.overbyte.eu/wiki/index.php/ICS_Download

ICS is a free internet component library for Delphi 7, 2006 to 2010, XE to XE8, 10 Seattle, 10.1 Berlin, 10.2 Tokyo, 10.3 Rio, 10.4 Sydney and 11.0 and C++ Builder 2006 to XE3, 10.2 Tokyo, 10.3 Rio, 10.4 Sydney and 11.0. ICS supports VCL and FMX, Win32, Win64 and MacOS 32-bit targets. The distribution zip includes the latest OpenSSL 1.1.1i win32, with OpenSSL 3.0 and Win64 versions of OpenSSL being available from the download page.

Changes in ICS V8.67 include:

1 - Added support and packages for RAD Studio 11.0.  Updated SSL/TLS root certificate bundles, old certificates gone, new ones added, nothing major.

2 - Added support for OpenSSL 3.0 which is a major new release, primarily a lot of internal changes to ease long term support. There is an optional FIPS module with 3.0 but not available here since our DLLs are not built to the standards required for certification. The old engines for special extensions are replaced by new more versatile providers of which the FIPS module is one, a provider legacy.dll has obsolete ciphers and hash digests, including MD2, MD4, Blowfish, DES, IDEA, RC2, RC4, SEED, that most applications no longer need and which needs to loaded by the application by setting global variable GSSLEAY_LOAD_LEGACY to true before loading OpenSSL.

3 - OpenSSL 3.0 does not offer any specific new features of benefit to ICS at present, although HTTP/3 support is planned for 3.1 or later, so the main ICS distribution retains OpenSSL 1.1.1i which is fully supported until September 2023. OpenSSL 3.0 may be downloaded from the download page. There are two global variables to restrict which OpenSSL version is loaded, GSSLEAY_DLL_IgnoreNew set true will ignore 3.0, while GSSLEAY_DLL_IgnoreOld will ignore 1.1.1, if both sets of DLLs are available in the same directory. The main SSL samples all set these globals, which can be changed for  testing one version or the other, or set by the application, but must be before OpenSSL is initialised.

4 - The main implication for ICS with OpenSSL 3.0 is for SSL/TLS certificate private keys saved with password protection, which is required for PKCS12 certificates for importing into the Windows certificate store. The new PKCS12 default password encryption AES256 is not recognised until Windows Server 2016 v1709  and Windows 10 v1709, so Server 2012, Windows 10 RTM and earlier won't load AES passworded keys, only 3DES, for which the legacy.dll must be loaded.

5 - The TX509Base class has various improvements. The ValidateCertChain method reports CA roots for multiple certificate verification paths with two or more intermediate certificates, rather than only the last. The CertMainInfo method provides a single line with the main certificate information.

6 - There are two new classes to write and read SSL/TLS certificates to and from the Windows Certificate Store, including private keys. This is primarily so Let's Encrypt certificates can be installed automatically for use with the IIS web server.  TMsX509List descends from TX509List adding a method LoadFromStore to load the list from a Windows certificate store by store name TMsCertStore and location MsCertLocation. For My/Personal store, attempts to load private keys if they are allowed to be exported unencrypted. TMsCertTools descends from TSslCertTools adding methods SaveToStorePfx and LoadFromMyStore to access Windows certificate stores. Note access to the Local Machine Store for web server certificates requires administrator rights.

7 - Various improvements for the OverbyteIcsPemTool sample.  It includes new buttons to list the  contents of Windows certificate and private key stores and allow old items to be deleted.  This may be useful for cleaning up old certificates and private keys from the Windows stores. Added ResavePrivateKey and Resave Private Key menu option which prompt for a PFX or PEM file containing an encrypted  private key with a new cipher, renaming old file to .oldpem/pfx.  Specifically for files saved with old ciphers than OpenSSL 3.0 does not support as standard if required for older versions of Windows.  Displaying certificates and bundles is no longer a new modal window, but updates the existing log window. Improved import certificates from Windows certificate store to use TMsX509List instead of Windows API calls, and to access all Windows store locations instead of just user, specifically the Local Machine store where server certificates are located.

8 - For the TX509Certs component, the default cipher for encrypting PFX/P12 files is now PrivKeyEncAES256 with 3.0 unless the legacy DLL is loaded when still PrivKeyEncTripleDES so older versions of Windows can load them. Changed extraction of download PEM bundle so that main certificate does not need to be first in file, log them all, and ignore any self signed root certificates. If testing dns-01 challenge fails, rotate to next public server and three retries (previously only happened on timeout). When saving files with private keys, log encryption type used. Added more certificate output formats, OutFmtPwPem and OutFmtPwP12 specify whether to password PEM and P12/PFX private keys. Note Windows always needs passworded P12/PRX files, while Apache web server only accepts PEM files without a password. Allow automatic installation of new certificates to the Windows Certificate Store so they can be used by IIS web sites, by setting output format to OutFmtWinStore.  Note application must have administrator rights to do this.

9 - Fixed two problems in the FTP client, support option ftpFixPasvLanIP for PUT/APPE uploads as well as  downloads, and support IPv6 for PUT/APPE uploads as well as downloads.

10 - Fixed a problem in TIcsMailQueue with sequential number generation to avoid file locking errors and unicode BOM corrupting file, generate large random number for errors instead of reverting to 1.  Don't save BOM withunicode compilers.

11 - In the Application Web Server TSslHttpAppSrv, added an optional LastModified parameter to the AnswerStream, AnswerPage, and AnswerString methods to avoid adding a custom header line with the date.  Added NO_CACHE_EX and NO_STORE_EX literals. Added PUT and DELETE verb handlers, similar to GET and POST.

12 - For the HTTP client TSslHttpCli, fixed a relocation problem where the Location: header included a path with a space, encode the space. Fixed another relocation problem where HEAD sometimes stalled. Remove # fragment or anchor from URL in relocation, only used by browsers and not by servers.

13 - In the TIcsBlackList component, Internally use BlockedFlag instead of setting attempts to 9999 once the actual maximum failed attempts is reached, so we can keep counting attempts.

14 - Added a new SSL sample, OverbyteIcsDDWebService.dpr which is very similar to OverbyteIcsSslMultiWebServ.dpr, but designed as a Windows service, although it will also run as a GUI for debugging.  It requires DDService service framework to be installed from https://www.magsys.co.uk/delphi/ddservice. asp. It also includes a REST server with simple lookup responses from a SQL
database, which optionally requires DISQLite3 5.36.5 or later to be installed from http://www.yunqa.de. Note this sample in not in the project groups due to these pre-requisites.

15 - Moved TRestParams from the OverbyteIcsSslHttpRest unit to OverbyteIcsUrl to ease circular references. Added a new method AddItemNULL to add a null, in Json this will be unquoted. Added a new TRestParamsSrv component which provides methods for creating REST server Json responses from a SQL database resultset, one or more rows, also error responses. Note this is only compiled if DATABASE is defined in OverbyteIcsDefs.inc to avoid bringing in database units that are not available on all Delphi editions.  There is a REST server sample OverbyteIcsDDWebService.dpr that illustrates SQL lookups.

16 - In the proxy component TIcsHttpProxy, don't send an HTTP request header until after HTTP body has been processed in case the body length changes. HTTP Forward Proxy using HTTP works again, broken in V8.65. Using HTTP Forward Proxy, convert absolute URL to path only since some servers can not process an absolute URL and sulk.

17 - In the Jose unit, rewrote the functions converting private keys to and from Json Web Keys with new OpenSSL 3.0 provider functions. Use AnsiStrings and functions when dealing with binary data to avoid possible issues with string conversions and nulls.  Json now created with TRestParams.

18 - Added two new sample project groups, OtherDemos64 and SslDemos64 which include Win64 versions of all the main active samples with 64 added to the project name, so they can be regularly built alongside the Win32 versions without changing platforms and overwriting executables.

 

Groupe "Développeurs Delphi et Pascal" francophone

 Le groupe "Développeurs Delphi et Pascal" vient d'être fondé sur LinkedIn.

C'est un groupe destiné à réunir les développeurs francophones qui utilisent Delphi ou le langage Pascal. Vous pouvez y poster - en Français - des questions techniques et des spécialistes vous aideront.

Bienvenue à tous !

TIniFile for Android and Windows

When writing cross platform applications, you are faced with different ways of doing thing depending on the platform. Thanks to the OOP paradigm, we may encapsulate those things in a class and create an implementation specific to each platform. This class hides all the details which are not readily portable.

In this article, I will model a class depending on the operation of the well-known Windows INI files. Of course, Windows own system will be used in the Windows implementation. On Android side, I will use the SharedPreferences API which is very close.

INI file concept

In an INI file, you have Key-Value pairs organized by sections. You can read or write values.

Under Windows, the INI file format is a simple text file with a Key=Value per line. All Key-Value pairs related to the same section are grouped under a header line in the form of the section name between brackets.

Under Android, the file format is not specified. You are not supposed to access the file directly. You use a “Shared Preference Editor” to access it. Android API lacks the “section” concept we have in Windows. This is not a problem. To create the section concept, I will simply prefix each key by his section name surrounded by brackets like this: ‘[‘ + Section + ‘]_’ + Key

Delphi TIniFile revisited

Since the beginning, Delphi has a class encapsulation Windows INI files. It is well named “TIniFile” and sits into “System.IniFiles” unit.

I will use the same class name in my implementation and even the save class signature by inheriting from the existing TCustomIniFile for Android and TIniFile for Windows.

Using the same class name as an existing one will force you to pay some attention to the units used in the uses clause, and/or prefix the class name you intent to use with the unit name.

I made things simples. Under both Windows and Android, in your application, you do not use System.IniFiles but FMX.Overbyte.IniFiles. No other change is required. Your application will compile targeted for Windows as well as Android. The conditional compilation is located in FMX.Overbyte.IniFiles and you can safely ignore it!

Storage location

TIniFile constructor takes a filename as argument. This will be the file where the sections and key-value pairs will be stored. The Windows API store the file exactly where you specify it when using a full path. When you omit the path, Windows tore the file in the Windows directory. Since Windows Vista, normal user cannot write to the Windows directory. So it fails.

I slightly changed the base class so that when a full path is omitted, the INI file is stored in the user profile LoaclAppData special directory (non-roaming version). This is a convenient place most of the time. You may always specify a full path name if you want to store it elsewhere.

Android has a “well known” place to store the preference files. We are not supposed to know where. The actual files are not available directly unless your Android device is rooted.

TIniFile constructor in the Android implementation will simple ignore any path you specify and let Android API store the file where it want it to be stored. This could cause a problem if you want to use the same file name for different files stored in different folders. This will cause trouble since the path is ignored.

Windows implementation

The windows implementation is quite trivial since it already exists in Delphi RTL. As stated above, I derived my class from Delphi existing class and only override the constructor to adjust the path when left empty.

The resulting declaration is trivial:

    TIniFile = class(System.IniFiles.TIniFile)
    public
        constructor Create(const AFileName : String);
    end;

The implementation is simple:

constructor TIniFile.Create(const AFileName: String);
var
    FileName     : String;
    Path         : array [0..1023] of Char;
    AppExeName   : array [0..1023] of Char;
    AppName      : String;
    LocalAppData : String;
begin
    if ExtractFilePath(AFileName) = '' then begin
        GetModuleFileName(0, AppExeName, Sizeof(AppExeName));
        SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, @Path[0]);
        AppName        := ChangeFileExt(ExtractFileName(AppExeName), '');
        LocalAppData   := IncludeTrailingPathDelimiter(Path) +
                           CompanyFolder + '\' + AppName + '\';
        FileName       := LocalAppData + AFileName;
        ForceDirectories(LocalAppData);
    end
    else
        FileName := AFileName;

    inherited Create(FileName);
end;

This implementation makes use of SHgetFolderPath API function to get the special directory “LocalAppData” located in each user profile. I used ForceDirectories to create the directory if it does not already exist.

You may want to change the location by changing the constant CSIDL_LOCAL_APPDATA to another one (There is a bunch of such constant, see the API documentation or Delphi source code if you have an edition which includes it).

You may also want to change the string constant “CompanyFolder” to your actual company name instead of OverByte which is my company name.

Using the demo application named “IniFileDemo”, running under Win7, the INI files without path will be stored in “C:\Users\\AppData\Local\OverByte\IniFileDemo”.

Android implementation

Android implementation makes use of SharedPreferences API which is already defined by Delphi runtime library. You handle that API using an interface named “JSharedPreferences” which is located in Androidapi.JNI.GraphicsContentViewText.

We need to implement most of the TIniFile methods. We can skip the read/write for other data types than string because they are all based on the read/write string.

The class declaration looks like this:

    TIniFile = class(System.IniFiles.TCustomIniFile)
    private
        FPrefs : JSharedPreferences;
        function InitPrefs : JSharedPreferences;
        function Key(const Section, Ident : String) : JString;
        procedure ReadSectionKeysValues(const Section : String;
                                        const KeyOnly : Boolean;
                                        Strings       : TStrings);
    public
        constructor Create(const FileName: String);
        function  ReadString(const Section, Ident, Default: String): String; override;
        procedure WriteString(const Section, Ident, Value: String); override;
        procedure ReadSection(const Section: String; Strings: TStrings); override;
        procedure ReadSections(Strings: TStrings); override;
        procedure ReadSectionValues(const Section: String; Strings: TStrings); override;
        procedure DeleteKey(const Section, Ident: String); override;
        procedure EraseSection(const Section: string); override;
        procedure UpdateFile; override;
    end;

The class TIniFile derives from existing TCustomIniFile. I used the fully qualified class name to avoid confusion (Here it is not strictly necessary since we do not redefine TCustomIniFile).

All the public methods are those required to make TIniFile work as it does under Windows. Private members are required as helpers for the implementation. As their visibility implies, you will never directly use them.

All methods need to get hand on a JSharedPreferences interface. That is why I created a member variable FPrefs to store it and an InitPrefs method to initialize it.

Once you get FPrefs, you may use it to fetch a value. look at ReadString implementation:

function TIniFile.ReadString(const Section, Ident, Default: String): String;
begin
    InitPrefs;
    Result := JStringToString(FPrefs.GetString(Key(Section, Ident),
                                               StringToJString(Default)));
end;

FPrefs.GetString is themethod use to retrieve (read) a stored value given his key. Here, as explained above, we implement the concept of section, so the key is really constructed using the section name and the identifier used outside of the class as key.

JStringToString and StringToJString are support functions to marshal back and forth a Delphi string to a Java string (Remember Android API is written in Java).

ReadSection, ReadSections and ReadSectionValues all require to enumerate all keys are save values in a string list for some of the keys if they match a condition. Iterating all the keys is a common process so I moved it to a specialized private method ReadSectionKeysValues.

Here is the implementation:

procedure TIniFile.ReadSectionKeysValues(
    const Section : String;  // Section to read, or empty for keys and values
    const KeyOnly : Boolean;
    Strings       : TStrings);
var
    AMap     : JMap;
    ASet     : JSet;
    AIter    : JIterator;
    AObj     : JObject;
    AString  : JString;
    DString  : String;
    ASection : String;
    AIdent   : String;
    I, J     : Integer;
begin
    if not Assigned(Strings) then
        Exit;
    InitPrefs;
    Strings.Clear;
    AMap  := FPrefs.GetAll;
    if not Assigned(AMap) then
        Exit;
    ASet  := AMap.entrySet;
    if not Assigned(ASet) then
        Exit;
    AIter := ASet.iterator;
    Strings.BeginUpdate;
    while AIter.hasNext do begin
        AObj    := AIter.next;
        AString := AObj.toString;
        DString := JStringToString(AString);
        // We get "[Section]_Ident"
        if (Length(DString) > 3) and (DString[Low(DString)] = '[') then begin
            I := Pos(']', DString);
            if I > 0 then begin
                ASection := Copy(DString, 2, I - 2);
                if Section = '' then begin
                    // We are reading section names
                    if Strings.IndexOf(ASection) < 0 then
                        Strings.Add(ASection);
                end
                else if SameText(Section, ASection) then begin
                    // We are reading the key names (Ident)
                    if KeyOnly then
                        J := PosEx('=', DString)
                    else
                        J := Length(DString) + 1;
                    if J > 0 then begin
                        AIdent := Copy(DString, I + 2, J - I - 2);
                        Strings.Add(AIdent);
                    end;
                end;
            end;
        end;
    end;
    Strings.EndUpdate;
end;

SharedPreferences Android API make use of string collection returned by getAll method to store all the preferences values. It is a generic Java class which can be accessed using a JMap interface which is available to Delphi program. Accessing the individual strings is 4 steps process:
1) Get the JMap interface by calling getAll
2) Get the JSet interface on behalf f the JMap
3) Get the JIterator on behalf og the JSet
4) Iterate with the JIterator to get hand of all object in the collection
The objects are here JStrings we can convert to Delphi string and process them.

The enumerated strings looks like this: “[Section1]_Key1=Value1”. We can then easily parse the string to extract the parts and do whatever we need with it.

The rest of the class implementation is quite trivial.

Full source code

The source code as well as a demo application is available from my website at
http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

FMX.Overbyte.IniFiles.pas

unit FMX.Overbyte.IniFiles;
{$DEFINE OVERBYTE_INCLUDE_MODE}
{$IFDEF ANDROID}
    {$I FMX.Overbyte.Android.IniFiles.pas}
{$ENDIF}
{$IFDEF MSWINDOWS}
    {$I FMX.Overbyte.Windows.IniFiles.pas}
{$ENDIF}

FMX.Overbyte.Windows.IniFiles.pas

{$IFNDEF OVERBYTE_INCLUDE_MODE}
unit FMX.Overbyte.Windows.IniFiles;
{$ENDIF}

interface

uses
    System.SysUtils, System.Classes, System.IniFiles,
    WinApi.Windows,
    WinApi.ShlObj;

const
    CompanyFolder = 'OverByte';

type
    // We are enhancing Embarcadero implementation
    TIniFile = class(System.IniFiles.TIniFile)
    public
        constructor Create(const AFileName : String);
    end;

implementation

{ TIniFile }

constructor TIniFile.Create(const AFileName: String);
var
    FileName     : String;
    Path         : array [0..1023] of Char;
    AppExeName   : array [0..1023] of Char;
    AppName      : String;
    LocalAppData : String;
begin
    // When the path is empty, Windows use Windows directory (C:\windows). This
    // is bad since Win7 which requires special permission to write to this
    // directory.
    // This implementation redirect the INI file to the user profile, that is
    // \Local Settings\Application Data (non roaming)
    // If you really want to write to Windows directory, then you must
    // specify that path name specifically.
    if ExtractFilePath(AFileName) = '' then begin
        GetModuleFileName(0, AppExeName, Sizeof(AppExeName));
        SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, @Path[0]);
        AppName        := ChangeFileExt(ExtractFileName(AppExeName), '');
        LocalAppData   := IncludeTrailingPathDelimiter(Path) +
                           CompanyFolder + '\' + AppName + '\';
        FileName       := LocalAppData + AFileName;
        ForceDirectories(LocalAppData);
    end
    else
        FileName := AFileName;

    inherited Create(FileName);
end;

end.

FMX.Overbyte.Android.IniFiles.pas

{$IFNDEF OVERBYTE_INCLUDE_MODE}
unit FMX.Overbyte.Android.IniFiles;
{$ENDIF}

interface

uses
    System.SysUtils, System.Classes, System.IniFiles, System.StrUtils,
    FMX.Helpers.Android,
    Androidapi.NativeActivity,
    Androidapi.JNI,
    Androidapi.JNI.App,
    Androidapi.JNI.GraphicsContentViewText,
    Androidapi.JNI.JavaTypes;

type
    TIniFile = class(System.IniFiles.TCustomIniFile)
    private
        FPrefs : JSharedPreferences;
        function InitPrefs : JSharedPreferences;
        function Key(const Section, Ident : String) : JString;
        procedure ReadSectionKeysValues(const Section : String;
                                        const KeyOnly : Boolean;
                                        Strings       : TStrings);
    public
        constructor Create(const FileName: String);
        function  ReadString(const Section, Ident, Default: String): String; override;
        procedure WriteString(const Section, Ident, Value: String); override;
        procedure ReadSection(const Section: String; Strings: TStrings); override;
        procedure ReadSections(Strings: TStrings); override;
        procedure ReadSectionValues(const Section: String; Strings: TStrings); override;
        procedure DeleteKey(const Section, Ident: String); override;
        procedure EraseSection(const Section: string); override;
        procedure UpdateFile; override;
    end;

implementation

{ TIniFile }

constructor TIniFile.Create(const FileName: String);
begin
    // Under Android, just ignore the path part because Android has a well
    // known place to store preferences files
    inherited Create(ExtractFileName(FileName));
end;

procedure TIniFile.DeleteKey(const Section, Ident: String);
var
    Edit  : JSharedPreferences_Editor;
begin
    InitPrefs;
    Edit := FPrefs.Edit;
    Edit.Remove(Key(Section, Ident));
    Edit.Apply;
end;

procedure TIniFile.EraseSection(const Section: String);
var
    Idents : TStringList;
    Edit  : JSharedPreferences_Editor;
    I     : Integer;
begin
    Idents := TStringList.Create;
    ReadSectionKeysValues(Section, TRUE, Idents);
    InitPrefs;
    Edit := FPrefs.Edit;
    for I := 0 to Idents.Count - 1 do
        Edit.Remove(Key(Section, Idents[I]));
    Edit.Apply;
end;

function TIniFile.InitPrefs : JSharedPreferences;
begin
    if not Assigned(FPrefs) then
        FPrefs := SharedActivityContext.getSharedPreferences(
                      StringToJString(FileName),
                      TJActivity.JavaClass.MODE_PRIVATE);
    Result := FPrefs;
end;

function TIniFile.Key(const Section, Ident: String): JString;
begin
    Result := StringToJString('[' + Section + ']_' + Ident);
end;

procedure TIniFile.ReadSection(const Section: String; Strings: TStrings);
begin
    if Section = '' then begin
        if Assigned(Strings) then
            Strings.Clear;
    end
    else
        ReadSectionKeysValues(Section, TRUE, Strings);
end;

procedure TIniFile.ReadSections(Strings: TStrings);
begin
    ReadSectionKeysValues('', FALSE, Strings);
end;

procedure TIniFile.ReadSectionKeysValues(
    const Section : String;  // Section to read, or empty for keys and values
    const KeyOnly : Boolean;
    Strings       : TStrings);
var
    AMap     : JMap;
    ASet     : JSet;
    AIter    : JIterator;
    AObj     : JObject;
    AString  : JString;
    DString  : String;
    ASection : String;
    AIdent   : String;
    I, J     : Integer;
begin
    if not Assigned(Strings) then
        Exit;
    InitPrefs;
    Strings.Clear;
    AMap  := FPrefs.GetAll;
    if not Assigned(AMap) then
        Exit;
    ASet  := AMap.entrySet;
    if not Assigned(ASet) then
        Exit;
    AIter := ASet.iterator;
    Strings.BeginUpdate;
    while AIter.hasNext do begin
        AObj    := AIter.next;
        AString := AObj.toString;
        DString := JStringToString(AString);
        // We get "[Section]_Ident"
        if (Length(DString) > 3) and (DString[Low(DString)] = '[') then begin
            I := Pos(']', DString);
            if I > 0 then begin
                ASection := Copy(DString, 2, I - 2);
                if Section = '' then begin
                    // We are reading section names
                    if Strings.IndexOf(ASection) < 0 then
                        Strings.Add(ASection);
                end
                else if SameText(Section, ASection) then begin
                    // We are reading the key names (Ident)
                    if KeyOnly then
                        J := PosEx('=', DString)
                    else
                        J := Length(DString) + 1;
                    if J > 0 then begin
                        AIdent := Copy(DString, I + 2, J - I - 2);
                        Strings.Add(AIdent);
                    end;
                end;
            end;
        end;
    end;
    Strings.EndUpdate;
end;

procedure TIniFile.ReadSectionValues(const Section: String; Strings: TStrings);
begin
    if Section = '' then
        Strings.Clear
    else
        ReadSectionKeysValues(Section, FALSE, Strings);
end;

function TIniFile.ReadString(const Section, Ident, Default: String): String;
begin
    InitPrefs;
    Result := JStringToString(FPrefs.GetString(Key(Section, Ident),
                                               StringToJString(Default)));
end;

procedure TIniFile.UpdateFile;
begin
    // Nothing to do
end;

procedure TIniFile.WriteString(const Section, Ident, Value: String);
var
    Edit  : JSharedPreferences_Editor;
begin
    InitPrefs;
    Edit := FPrefs.Edit;
    Edit.PutString(Key(Section, Ident), StringToJString(Value));
    Edit.Apply;
end;

end.

Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be

OOP design and event driven programming

In a previous article, one of the 3 main design advices was “Use events to free your classes from things that can change”. In this article, I would like to talk a little bit more about it.

Following good OOP practice, you develop by encapsulating almost everything into specialized objects. This makes all the code and all data related to a given subject grouped into a single entity named object.

This encapsulation is quite easy. You first this about what the object is or made of, and what operation can be done on the object or with the object. What the object is or is made of becomes properties. Operations become methods.

Let’s see this in action with a very simple and basic example derived from one of my real world applications. You can skip the following 3 paragraphs if you are not interested by the actual application and only want to read software design part of this article.

First, a little background: As you may know I’m working for a company building – among other things – automated digital radiography (DR) system. A DR system is made of an X ray source, an X ray detector, a diaphragm, a manipulator, a control computer, an image processing system and a database system. It is automated because it does X ray inspection without human interaction. It takes hundreds of radiography fully unattended.

You can see a picture here. OK, when you don’t know what it is, it could be challenging to understand what you see. Actually in the background in orange you see a robotic arm. It holds a fork which support the X ray detector (White rectangular box on the left), the diaphragm (Yellow on the right) and the X ray source (just behind the diaphragm). On the foreground, you see the part being inspected (Component of the low pressure compressor of an aircraft engine). This component is secured on a rotating table you don’t see on the picture.

What my Delphi software does is drive the robot, the rotating table, the X ray source, the diaphragm, and the detector in coordinated movement to take X ray picture of all welds. Pictures are sent to an image processing system for examination and then stored in a database for later search and retrieve.

For such a complex system, it is very important to have a good software design. If you don’t, the application will be horrible to maintain and would probably quickly become unreliable.

Objects are defined at all levels in the application. High level objects making use of low level objects. Each object is specialized for his own purpose. If you don’t carefully think about the purpose, you’ll end up with a single huge object doing everything; or you get a myriad of object doing almost nothing each one. There is no rule to fix the boundaries. Your only guide I can give you is to always think about what the main purpose of the object is and concentrate on it. Everything that doesn’t fit the real purpose must be moved to another object with his own purpose.

Back to our real world example: Both the robot and the rotating table make use of serial communication (RS232 or RS485) between the computer and the electronic and embedded controller driving the motors. They use the same physical communication layer but different protocols. We can immediately see the object candidates, from low level to high level: Basic serial communication, robot communication protocol, rotating table communication protocol, robot itself and rotating table itself.

The basic serial communication will simply drive the computer serial port to send and receive characters. It has no knowledge of what represent the data sent or receive. It only knows how to send data and receive data.

Communication protocol object handle messages required to instruct a robot controller or a rotating table motor controller to do what it needs to. This object doesn’t know how to send characters to a serial port. It even doesn’t know it is making use of a serial port. But it knows how to format a message instructing the robot or the table to reach a given position. The communication protocol object has no idea what is the movement purpose, but it know how to request such movement.

Robot or rotating table objects are high level objects. They know what a robot or table is able to do, they know which sequences of instructions are required for everything a robot or table can do, at least from a low level point of view. The error to be avoided here is to put in that object something related to yet a higher level. That higher level is related to the coordination between the robot and the table, or related to the whole systems.

I have just scratched the surface of the OOP design for such an application. I don’t want to teach you how to build software for automated digital radiography system. I want to teach you how to write good Delphi code (Well, this applies to almost all object oriented programming language).

An object in the middle of a hierarchy receive order from the higher level and has to delegate work to the lower level objects. Those are simple method calls. For example, the robot having to move the arm to a given X, Y, Z position is space (You also need the 3 angles to fully define a position in space) will call a bunch of methods of the communication protocols, probably a message to send each parameter (coordinates and angles) to the robot controller. The communication protocol object will build messages, adding addresses, message number, checksum or CRC and similar items required to make a valid message. It will delegate the sending of the message to the lowest level object handling serial port communication. This object doesn’t know what the messages are but knows how to send it one byte or character at a time, with proper baud rate, parity, start and stop bit, and how to handle handshaking.

So far so good: we only used simple method calls up to now. We are now at the point where we need even driven programming!

The software is driving hardware. Moving a robot arm or rotating a table takes a huge time compared to the computer processing speed. What happens when the requested movement is done or when something went wrong? There is a data flow in the reverse direction! The hardware (Motor controller) sends a message thru the serial port to say – for example – the position has been reached.

The lowest level object receives bytes from the motor controller. After checking errors such as parity, it transmits those bytes to the communication protocol object which assembles complete messages. Messages are checked for validity (format, length, CRC, and so on). Complete messages are then used to notify the robot object or table object that the requested movement is done. It is likely that a single movement is part of a group of coordinated movement. The robot object knows about this coordination and collects all messages until the group is finished and only then forwards the information to the upper layer.

In an event driven software, the backward information flow is handled by events. This means that the software send a request for something and don’t care waiting until the requested operation is done. Rather, it handles notification when something happens, for example the end of requested operation or an error message. This event driven operation is frequently called asynchronous operation because requesting something is decoupled from waiting for it to be done.

Traditional programming, also known as synchronous programming or blocking programming, works by sending a request and waiting for the answer. This is simple and easy. Well easy until you have to do several things simultaneously. With synchronous programming you must then use multithreading to do several thing simultaneously. This works well but it is difficult to develop, debug and maintain. There are a lot of issues arising from thread synchronization. This is a very difficult matter.

Asynchronous programming or event driven programming solves those issues easily. There is no problem at all doing several things simultaneously since “things” are merely requests to do something. The request is almost instantaneous. There is no wait, no blocking. The program never wait that something is done. It just does the processing when it is done.

Think about Windows user interface. Your code never wait that the user clicks on a button. You just assign code to the event which is triggered when the user clicks on the button. The code is executed when the user clicks and you have nothing to do for that to happen.

This event driven behavior can be built into your own objects very easily. It fits very well along to the code you write for the user interface.

Here are the required steps:

1. Think about which data you need to pass when the event is triggered
2. Create a data type corresponding to the data found in step 1. Add a “Sender” argument. This data type is a pointer to a procedure of object.
3. Create a protected member variable in your class to hold the data type from step 2. Usually this member variable name begins with “FOn”.
4. Create a published property corresponding to the member variable.
5. Create a protected “Trigger” virtual procedure.
6.  Implement the trigger procedure

You want an example? The communication protocol object which receive data from the serial communication object will trigger an event when it has assembled a full message and this message in a message stating the position of the movement (Usually motor controller periodically send such message while moving). It is likely that the data is the actual position. This position is usually expressed as an integer count of a position encoder tick.

Step 1:
We need an integer.

Step 2:

type
  TPositionEvent = procedure (Sender : TObject; Position : Integer) of object;

Step3:

protected
  FOnXPosition : TPositionEvent;
  

Step 4:

  published
    property OnXPosition : TPositionEvent read  FOnXPosition
                                          write FOnXPosition;

Step 5:

protected
    procedure TriggerXPosition(Position : Integer); virtual;

Step 6:

procedure TMyObject.TriggerXPosition(Position: Integer);
begin
    if Assigned(FOnXPosition) then
        FOnXPosition(Self, Position);
end;

Usually I use a single source file for each individual object.
The complete code should looks like this:

unit RobotCommProtocol;

interface

uses
  Classes;

type
  TPositionEvent = procedure (Sender : TObject; Position : Integer) of object;

  TRobotProtocol = class(TComponent)
  protected
    FOnXPosition : TPositionEvent;
    procedure TriggerXPosition(Position : Integer); virtual;
  published
    property OnXPosition : TPositionEvent read  FOnXPosition
                                          write FOnXPosition;
  end;


implementation

procedure TRobotProtocol.TriggerXPosition(Position: Integer);
begin
    if Assigned(FOnXPosition) then
        FOnXPosition(Self, Position);
end;

end.

Carefully study how I named the various parts. Naming convention is very important to have readable and maintainable code. Keep naming same thing with same name, using prefixes or suffixes to make a distinction where required.

My event is supposed to return a position. Assuming we have several possible positions, I named everything related to the event “XPosition”. The data type is named “TPositionEvent” because the same event will apply to X, Y, Z and all others so the “X” has been dropped. It is to be used for an event so the suffix is “Event”. And it begins with letter “T” because it is a data type.

The property itself is named “OnXPosition” for obvious reasons. Think about the “OnClick” event of a TButton. This is similar.

The member variable has the same name as the property with an “F” prefix. This convention is almost always used.

The trigger procedure begins with prefix “Trigger” and become TriggerXPosition. When the object needs to trigger the OnXPosition event, it will call TriggerXPosition, passing the new position. The procedure is made virtual so that derived classes have a chance to override his behavior. For example, the derived class could enhance it be triggering another event when the value exceed some limit.

The unit containing the code has been named “RobotCommProtocol” because our object handles a communication protocol for a given robot. The object itself is named “TRobotProtocol” for obvious reasons. It derives from TComponent which makes possible to install the object as a component available in Delphi IDE component palette. There are other requirements which are out of this article scope.

There is much more to say about the topic. Please post a comment to the article to ask for the topics I should develop in the next article.



Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be

Delphi uses Excel to create a chart in a PDF document

Microsoft Excel exposes all his features thru a COM interface which can easily be used from a Delphi application. In this article, I use that feature to create a 3D pie chart from data available within a Delphi program and produce a PDF document.

I already talked about using Microsoft Office applications in this article. I gave examples using Word. In this article I use Excel for what it does very well: take an array of data and produce a nice chart.

Excel exposes a number of objects and this makes programming it a little bit confusing at first. The three most important objects are:

• ExcelApplication: this is the whole Excel application.
• WorkBook: This is a spreadsheet file
• WorkSheet: This is a page within a workbook.

There are a lot of other objects or object collections. In this article we will use “Cells” and “Charts”. They are exactly what their names imply.

Each object or collection has a lot of properties and methods. This is where it becomes quite complex. Although most names are explicit, their use isn’t. Microsoft publishes a lot of documentation (http://msdn.microsoft.com/en-us/library/office/bb726434(v=office.12).aspx). Of course none of this documentation is written using Delphi syntax. Nevertheless it is of great help even if most samples are VBA or C#.

There are a large number of Office versions. The programming interface change slightly between each version but all in all, upward compatibility is excellent. The gold rule is to always use the oldest API version suitable for what you need to do. Because of upward compatibility, your application will generally work for the version you selected and all more recent versions.

For my sample application, I used Excel 2010. Microsoft reference is here.

In Delphi, you must use the correct components. See discussion in this article. What I said then for XE4 is valid for XE5 as well as previous versions.

My demo application is simple: A single VCL form with a single button. The button’s OnClick handler connect to excel, create a workbook having a worksheet, fill cells with simple data, create a new chart with the data, export the chart as a PDF file, close the workbook and Excel.

I hardcoded the data to keep the code simple. It is quite trivial to fetch data from anywhere, including some database. How the data is fetched is not today’s article object.

There are a number of traps when writing this kind of application. Most Office API functions have a lot of arguments. Most of them can be left empty. When you specify some argument the code may triggers an access violation or an OLE error. For example, when adding a chart, on argument specifies the chart type. I’ve found that using it will trigger an OLE error. I had to left it empty and then change the property ChartType to actually change the type of chart. This is really annoying because error messages are not explicit at all! It is a try and error play. It is time consuming.

The resulting code is very short and simple indeed:

procedure TForm1.Button1Click(Sender: TObject);
var
    WBook  : ExcelWorkbook;
    WSheet : ExcelWorksheet;
    Row    : Integer;
    WChart : ExcelChart;
    LCID   : Integer;
begin
    // Get the locale identifier for the user default locale
    LCID := GetUserDefaultLCID;
    //Connect to Excel application, this will launch excel
    ExcelApplication1.Connect;
    // Make excel visible (This is not required)
    ExcelApplication1.Visible[LCID] := TRUE;
    // Create a new workbook with a new sheet
    WBook  := ExcelApplication1.Workbooks.Add(xlWBATWorksheet, LCID);
    WSheet := WBook.ActiveSheet as ExcelWorksheet;
    // Add some data to the sheet
    WSheet.Cells.Item[1, 1] := 'Item';
    WSheet.Cells.Item[1, 2] := 'Quantity';
    for Row := 0 to High(Data) do begin
        WSheet.Cells.Item[2 + Row, 1] := Data[Row].Item;
        WSheet.Cells.Item[2 + Row, 2] := Data[Row].Quantity;
    end;
    // Create a new chart
    WChart := WBook.Charts.Add(EmptyParam, EmptyParam,
                               EmptyParam, EmptyParam, LCID) as ExcelChart;
    // Set the chart type
    WChart.ChartType := xl3DPie;
    // Set the tab name
    WChart.Location(xlLocationAsNewSheet, 'MyChart');
    // Export the chart as a PDF file
    WChart.ExportAsFixedFormat(xlTypePDF, 'MyChart.pdf', xlQualityStandard,
                               TRUE, FALSE, EmptyParam, EmptyParam,
                               TRUE,         // Open after published
                               EmptyParam);
    // Close the workbook, quit excel and disconnect
    WBook.Close(FALSE, EmptyParam, EmptyParam, LCID);
    ExcelApplication1.Quit;
    ExcelApplication1.Disconnect;
end;

--
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be
This article is available from http://francois-piette.blogspot.be

Delayed loading of a DLL

The delayed directive can be used when declaring a function exported from a DLL so that the DLL is not loaded before the function is called.

This is very useful because you may first check if the conditions are met to call the DLL before actually loading the DLL, for example check if the DLL is located where it should.

If you statically load a DLL (the default), then your application won’t start if the DLL is not present. You could as well dynamically load the DLL (LoadLibrary) to avoid this issue, but it is a little bit more work for you to declare function pointer and the get each function address (GetProcAddress) by code. Using delayed directive is much easier. Just add delayed keyword in each function declaration and suddenly a static DLL is loaded the first time one of his functions is called. If you never call a DLL’s function, then the DLL is not loaded at all.

A declaration looks like this:

    function GetSomething: Integer; external 'somelibrary.dll' delayed;

This directive exists since Delphi 2010. There is valuable documentation on Embarcadero DocWiki at this URL: http://docwiki.embarcadero.com/RADStudio/XE4/en/Libraries_and_Packages#Delayed_Loading And you can find some code sample here: http://docwiki.embarcadero.com/CodeExamples/XE4/en/DelayedLoading_(Delphi)

Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

Drag And Drop from Windows Explorer

This article presents the required code to handle drag& drop of images from Windows Explorer to your Delphi application. The demo code shows how to drop images on a TListView and to drag & drop from TListView to a TImage.

The code is fairly basic and made so that it can be clearly understood and applied to other types of controls.

Drag & Drop from windows Explorer is handled by an application by registering a window handle along with an instance of an IDropTarget interface.

To make to code easy to reuse, I encapsulated the IDropTarget implementation into a class named TDropTarget and expose the features the Delphi way: using event.

To allow Drag & Drop from Windows Explorer to one of your form, you have to create an instance of TDropTarget and call his Register method passing the form’s handle. Of course you have to assign the events to handler in your form. The events handle all drag and drop operation:

DropAllowed event is called once when the dragged files are entering the area of the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.

DragOver event is called as mouse move above the registered window. The event handler must set the “Allowed” var argument to TRUE if dropping the file(s) is allowed at the given point.

Drop event is called when the user drops the files.

DragLeave event is called when the dragged files leave the registered window area.

I could have made a component of TDropTarget but I didn’t. It is a simple object deriving from Object. As it implements an interface IDroptarget, beside the methods of this interface, the object also has to handle _AddRef, _Release and QueryInterface methods which exist in all interfaces. Here we use TObject life cycle, so those methods are simply do-nothing methods.

The code required in your form include creating the object in the form’s contructor (or FormCreate event), assign the event handlers. And of course free the object instance in the destructor:

constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
    FDropTarget               := TDropTarget.Create;
    FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
    FDropTarget.OnDrop        := ImageDropHandler;
    FDropTarget.OnDragOver    := ImageDragOverHandler;
    inherited Create(AOwner);
end;

destructor TDragDropMainForm.Destroy;
begin
    FreeandNil(FDropTarget);
    inherited;
end;

Register and Revoke should be called when the window handle is created or destroyed. For that, we have to override CreateWnd and DestroyWnd.

procedure TDragDropMainForm.CreateWnd;
begin
    inherited CreateWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Register(Handle);
end;

procedure TDragDropMainForm.DestroyWnd;
begin
    inherited DestroyWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Revoke;
end;

The demo application uses a TListView in vsList view mode and a TImage. The ListView accept the dropped images from Windows Explorer while TImage accepte images dropped from TListView. It is a good exercise for you to make TImage accept image also from Windows Explorer.

The demo application doesn’t show image in real size in TListView. Rather, it creates a thumbnail which is displayed in the list view. The thumbnails are stored on disk in the same folder as the original image and are only created if it doesn’t exist yet, or if the original image has been modified. Storing the thumbnail on disk could be a problem in some application because it requires write permission. In my application (Well the application I extracted this code from), it is an advantage because the images are very large and it takes time to create the thumbnails. Keeping the thumbnails on disk improve performance.

Thumbnails are created using GDI+ (See my other blog article about it: http://francois-piette.blogspot.be/2013/05/opensource-gdi-library.html). The code is really easy:

 Image := TGPImage.Create(AFileName);
    Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
    Quality := 50;
    Params := TGPEncoderParameters.Create;
    Params.Add(EncoderQuality, Quality);
    Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);

A last note about the demo application: I used custom draw of the ListView items so that it looks exactly how I require it. All list view items are represented by a class named TImageListViewItem. I have selected this representation because in the real application this demo is extracted from, there is a lot of information about each image. The class is really handy to hold the information and the processing related to it.


Here after is the complete source code. There are mainly two files: DropHanlder.pas and DragDropMain.pas. You can also download a zip file with the complete project. See my website at: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

DropHandler.pas

unit DropHandler;

interface

uses
    Windows, Types, Classes, SysUtils, ShellAPI, ActiveX;

type
    TStringArray      = array of String;

    TDropAllowedEvent = procedure (Sender            : TObject;
                                   const FileNames   : array of String;
                                   const grfKeyState : Longint;
                                   const pt          : TPoint;
                                   var   Allowed     : Boolean)
                                 of object;
    TDragOverEvent    = procedure (Sender            : TObject;
                                   const grfKeyState : Longint;
                                   const pt          : TPoint;
                                   var   Allowed     : Boolean)
                                 of object;
    TDropEvent        =  procedure (Sender           : TObject;
                                    const DropPoint  : TPoint;
                                    const FileNames  : array of String)
                                 of object;

    TDropTarget = class(TObject, IDropTarget)
    private
        FRegisteredHandle : HWND;
        FDropAllowed      : Boolean;
        FOnDropAllowed    : TDropAllowedEvent;
        FOnDrop           : TDropEvent;
        FOnDragOver       : TDragOverEvent;
        FOnDragLeave      : TNotifyEvent;
        procedure GetFileNames(const dataObj : IDataObject;
                               var FileNames : TStringArray);
        function  DragEnter(const dataObj : IDataObject;
                            grfKeyState   : Integer;
                            pt            : TPoint;
                            var dwEffect  : Integer): HResult; stdcall;
        function  DragOver(grfKeyState  : Longint;
                           pt           : TPoint;
                           var dwEffect : Longint): HResult; stdcall;
        function  DragLeave: HResult; stdcall;
        function  Drop(const dataObj : IDataObject;
                       grfKeyState   : Longint;
                       pt            : TPoint;
                       var dwEffect  : Longint): HResult; stdcall;
        function _AddRef: Integer; stdcall;
        function _Release: Integer;  stdcall;
        function QueryInterface(const IID: TGUID; out Obj): HResult;  stdcall;
    public
        destructor  Destroy; override;
        // Call Register() with a window handle so that that window starts
        // accepting dropped files. Events will then be generated.
        function    Register(AHandle : HWnd) : HResult;
        // Stop accepting files dropped on the registered window.
        procedure   Revoke;
        // DropAllowed event is called once when the dragged files are
        // entering the area of the registered window.
        // The event handler must set the Allowed var argument to TRUE if
        // dropping the file(s) is allowed at the given point
        property OnDropAllowed : TDropAllowedEvent read  FOnDropAllowed
                                                   write FOnDropAllowed;
        // DragOver event is called as mouse move above the registered window
        // The event handler must set the Allowed var argument to TRUE if
        // dropping the file(s) is allowed at the given point
        property OnDragOver    : TDragOverEvent    read  FOnDragOver
                                                   write FOnDragOver;
        // Drop event is called when the user drops the files.
        property OnDrop        : TDropEvent        read  FOnDrop
                                                   write FOnDrop;
        // DragLeave event is called when the dragged files leave the
        // registered window area.
        property OnDragLeave   : TNotifyEvent      read  FOnDragLeave
                                                   write FOnDragLeave;
    end;

implementation


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Register(AHandle: HWnd): HResult;
begin
    if FRegisteredHandle = AHandle then begin
        Result := S_OK;
        Exit;
    end;
    if FRegisteredHandle <> 0 then
        Revoke;
    FRegisteredHandle := AHandle;
    Result  := ActiveX.RegisterDragDrop(FRegisteredHandle, Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.Revoke;
begin
    if FRegisteredHandle <> 0 then begin
        ActiveX.RevokeDragDrop(FRegisteredHandle);
        FRegisteredHandle := 0;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDropTarget.Destroy;
begin
    Revoke;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDropTarget.GetFileNames(
    const dataObj : IDataObject;
    var FileNames : TStringArray);
var
    I           : Integer;
    FormatetcIn : TFormatEtc;
    Medium      : TStgMedium;
    DropHandle  : HDROP;
begin
    FileNames            := nil;
    FormatetcIn.cfFormat := CF_HDROP;
    FormatetcIn.ptd      := nil;
    FormatetcIn.dwAspect := DVASPECT_CONTENT;
    FormatetcIn.lindex   := -1;
    FormatetcIn.tymed    := TYMED_HGLOBAL;
    if dataObj.GetData(FormatetcIn, Medium) = S_OK then begin
        DropHandle := HDROP(Medium.hGlobal);
        SetLength(FileNames, DragQueryFile(DropHandle, $FFFFFFFF, nil, 0));
        for I := 0 to high(FileNames) do begin
            SetLength(FileNames[I], DragQueryFile(DropHandle, I, nil, 0));
            DragQueryFile(DropHandle, I, @FileNames[I][1],
                          Length(FileNames[I]) + 1);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragEnter(
    const dataObj : IDataObject;
    grfKeyState   : Integer;
    pt            : TPoint;
    var dwEffect  : Integer): HResult;
var
    FileNames: TStringArray;
begin
    Result := S_OK;
    try
        GetFileNames(dataObj, FileNames);
        if (Length(FileNames) > 0) and Assigned(FOnDropAllowed) then begin
            FDropAllowed := FALSE;
            FOnDropAllowed(Self, FileNames, grfKeyState, pt, FDropAllowed);
        end;
        if FDropAllowed then
            dwEffect := DROPEFFECT_COPY
        else
            dwEffect := DROPEFFECT_NONE;
    except
        Result := E_UNEXPECTED;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragLeave: HResult;
begin
    if Assigned(FOnDragLeave) then
        FOnDragLeave(Self);
    Result := S_OK;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.DragOver(
    grfKeyState  : Integer;
    pt           : TPoint;
    var dwEffect : Integer): HResult;
begin
    Result := S_OK;
    try
        if Assigned(FOnDragOver) then
            FOnDragOver(Self, grfKeyState, pt, FDropAllowed);
        if FDropAllowed then
            dwEffect := DROPEFFECT_COPY
        else
            dwEffect := DROPEFFECT_NONE;
    except
        Result := E_UNEXPECTED;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.Drop(
    const dataObj : IDataObject;
    grfKeyState   : Integer;
    pt            : TPoint;
    var dwEffect  : Integer): HResult;
var
    FileNames: TStringArray;
begin
    Result := S_OK;
    try
        GetFileNames(dataObj, FileNames);
        if (Length(FileNames) > 0) and Assigned(FOnDrop) then
            FOnDrop(Self, Pt, FileNames);
    except
        // Silently ignore any exception bacsue if required, they should
        // be handled in OnDrop event handler.
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
    if GetInterface(IID, Obj) then
        Result := 0
    else
        Result := E_NOINTERFACE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._AddRef: Integer;
begin
    // We don't use reference counting in this object
    // We need _AddRef because RegisterDragDrop API call it
    Result := 1;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDropTarget._Release: Integer;
begin
    // We don't use reference counting in this object
    // We need _Release because RevokeDragDrop API call it
    Result := 1;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.

DragDropMain.pas

unit DragDropMain;

interface

uses
    Windows, Messages, Types, SysUtils, Variants, Classes, Graphics,
    StdCtrls, ExtCtrls, Controls, ComCtrls, CommCtrl, Forms, Dialogs,
    Jpeg, ImgList,
    GdiPlus,
    DropHandler;

const
    AtEndOfPipe      = -1;
    AtTopOfPipe      = -2;
    THUMBNAIL_SIZE   = 64;
    THUMBNAIL_MARGIN = 8;
    // List of accepted image file extensions
    Exts     : array [0..3] of String = ('.jpg', '.png', '.bmp', '.tif');

type
    TImageListViewItem = class
    public
        FileName          : String;
        Bitmap            : TBitmap;
        Data              : TObject;
        ThumbnailFileName : String;
        constructor Create(const AFileName          : String;
                           const AThumbnailFileName : String;
                           const AItem              : TListItem;
                           const AWidth             : Integer;
                           const AHeight            : Integer);
        destructor  Destroy; override;
    end;

    TDragDropMainForm = class(TForm)
        ListView1: TListView;
        Splitter1: TSplitter;
        Image1: TImage;
        procedure ListView1CustomDrawItem(Sender          : TCustomListView;
                                          Item            : TListItem;
                                          State           : TCustomDrawState;
                                          var DefaultDraw : Boolean);
        procedure ListView1Deletion(Sender : TObject;
                                    Item   : TListItem);
        procedure ListView1MouseDown(Sender : TObject;
                                     Button : TMouseButton;
                                     Shift  : TShiftState;
                                     X, Y   : Integer);
        procedure ListView1MouseMove(Sender: TObject;
                                     Shift : TShiftState;
                                     X, Y  : Integer);
        procedure ListView1MouseUp(Sender : TObject;
                                   Button : TMouseButton;
                                   Shift  : TShiftState;
                                   X, Y   : Integer);
    private
        FDropTarget              : TDropTarget;
        FMouseDownPt             : TPoint;
        FMouseMovePt             : TPoint;
        FMouseDownFlag           : Boolean;
        FDraggingImage           : Boolean;
        procedure ImageDragOverHandler(Sender            : TObject;
                                       const grfKeyState : Longint;
                                       const pt          : TPoint;
                                       var   Allowed     : Boolean);
        procedure ImageDropAllowedHandler(Sender            : TObject;
                                          const FileNames   : array of string;
                                          const GrfKeyState : Integer;
                                          const Pt          : TPoint;
                                          var   Allowed     : Boolean);
        procedure ImageDropHandler(Sender          : TObject;
                                   const DropPoint : TPoint;
                                   const FileNames : array of string);
        function  DropImage(const AFileName : String;
                            XScreen         : Integer;
                            YScreen         : Integer): Boolean;
        procedure CreateThumbnail(const AFileName      : String;
                                     var   AThumbFileName : String);
        function  KnownExtension(const FileName : String): Boolean; overload;
        function  KnownExtension(const FileNames: array of string): Boolean; overload;
    protected
        procedure CreateWnd; override;
        procedure DestroyWnd; override;
    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;
        procedure AddImage(const FileName : String;
                           BeforeIndex    : Integer);
        procedure MoveImage(IFrom, ITo: Integer);
        procedure RemoveImage(Index: Integer); overload;
        function  FindImage(const FileName: String): Integer;
        function  AppendImage(const FileName: String): Integer;
    end;

function ReplaceThumb(const FileName : String) : String;
function ListViewMouseToItem(
    Pt           : TPoint;
    LV           : TListView;
    var ColIndex : Integer): TListItem;

var
  DragDropMainForm: TDragDropMainForm;

implementation

{$R *.dfm}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{ TDragDropMainForm }

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TDragDropMainForm.Create(AOwner: TComponent);
begin
    FDropTarget               := TDropTarget.Create;
    FDropTarget.OnDropAllowed := ImageDropAllowedHandler;
    FDropTarget.OnDrop        := ImageDropHandler;
    FDropTarget.OnDragOver    := ImageDragOverHandler;
    inherited Create(AOwner);

    // To have TListView work correctly in vsList view mode, we must have
    // at least one group, one column and a SmallImages image list.
    ListView1.Groups.Clear;
    ListView1.Groups.Add;
    ListView1.Columns.Clear;
    ListView1.Columns.Add;
    // Height of displayed image is set by height of SmallImages
    ListView1.SmallImages        := TImageList.Create(Self);
    ListView1.SmallImages.Height := THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN;
    // Width of displayed image is set by ListView_SetColumnWidth macro with
    // column index set to zero.
    ListView_SetColumnWidth(ListView1.Handle, 0, THUMBNAIL_SIZE + 2 * THUMBNAIL_MARGIN);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateWnd;
begin
    inherited CreateWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Register(Handle);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDragDropMainForm.Destroy;
begin
    FreeandNil(FDropTarget);
    inherited;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.DestroyWnd;
begin
    inherited DestroyWnd;
    if Assigned(FDropTarget) then
        FDropTarget.Revoke;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDragOverHandler(
    Sender            : TObject;
    const grfKeyState : Longint;
    const pt          : TPoint;
    var   Allowed     : Boolean);
begin
    Allowed := TRUE;
    if not PtInRect(ListView1.BoundsRect, ListView1.ScreenToClient(Pt)) then begin
        Allowed := FALSE;
        Exit;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropAllowedHandler(
    Sender            : TObject;
    const FileNames   : array of string;
    const GrfKeyState : Integer;
    const Pt          : TPoint;
    var   Allowed     : Boolean);
begin
    Allowed := KnownExtension(FileNames);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ImageDropHandler(
    Sender          : TObject;
    const DropPoint : TPoint;
    const FileNames : array of string);
var
    I : Integer;
begin
    for I := 0 to High(FileNames) do
        DropImage(ReplaceThumb(FileNames[I]), DropPoint.X, DropPoint.Y);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.DropImage(
    const AFileName : String;
    XScreen         : Integer;
    YScreen         : Integer) : Boolean;
var
    Pt       : TPoint;
    Item     : TListItem;
    ColIndex : Integer;
begin
    Result := FALSE;
    // First check if the extension is allowed
    if not KnownExtension(AFileName) then begin
        ShowMessage('Unacceptable file type (' +
                    ExtractFileExt(AFileName) + ')');
        Exit;
    end;

    // Check if we already got the image
    if FindImage(AFileName) >= 0 then begin
        ShowMessage(AFileName + #10 + 'Already in the ListView, ignoring');
        Exit;
    end;

    // Check if the drop point is inside the ListView
    Pt := ListView1.ScreenToClient(Point(XScreen, YScreen));
    if not PtInRect(ListView1.BoundsRect, Pt) then
        Exit;
    // Check if dropped on an existing item
    Item := ListViewMouseToItem(Pt, ListView1, ColIndex);
    if not Assigned(Item) then
        AppendImage(AFileName)           // Not on an item, add at the end
    else
        AddImage(AFileName, Item.Index); // Insert before the item
    Result   := TRUE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1CustomDrawItem(
    Sender          : TCustomListView;
    Item            : TListItem;
    State           : TCustomDrawState;
    var DefaultDraw : Boolean);
var
    Bitmap  : TBitMap;
    Rc1     : TRect;
    Rc2     : TRect;
    Rc3     : TRect;
    ACanvas : TCanvas;
    YOff    : Integer;
    XOff    : Integer;
begin
    ACanvas := Sender.Canvas;
    Rc1 := Item.DisplayRect(drBounds);
    if Assigned(Item.Data) then begin
        Bitmap := TImageListViewItem(Item.Data).Bitmap;
        // Center the bitmap
        YOff := ((THUMBNAIL_SIZE - BitMap.Height) div 2) + THUMBNAIL_MARGIN;
        XOff := ((THUMBNAIL_SIZE - Bitmap.Width) div 2) + THUMBNAIL_MARGIN;
        ACanvas.Draw(Rc1.Left + 2 + XOff, Rc1.Top + 2 + YOff, Bitmap);

        // Draw a double FrameRect around the image with a color depending
        // on the status of the image
        Rc2.Left   := Rc1.Left + XOff;
        Rc2.Top    := Rc1.Top  + YOff;
        Rc2.Right  := Rc1.Left + Bitmap.Width  + 4 + XOff;
        Rc2.Bottom := Rc1.Top  + Bitmap.Height + 4 + YOff;
        Rc3.Left   := Rc1.Left + 1 + XOff;
        Rc3.Top    := Rc1.Top  + 1 + YOff;
        Rc3.Right  := Rc1.Left + Bitmap.Width  + 3 + XOff;
        Rc3.Bottom := Rc1.Top  + Bitmap.Height + 3 + YOff;

        if cdsSelected in State then
            ACanvas.Brush.Color := clBlue
        else if cdsHot in State then
            ACanvas.Brush.Color := clRed
        else
            ACanvas.Brush.Color := ListView1.Color;

        ACanvas.FrameRect(Rc2);
        ACanvas.FrameRect(Rc3);

        DefaultDraw := FALSE;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1Deletion(
    Sender : TObject;
    Item   : TListItem);
begin
    if Assigned(Item.Data) then
        TObject(Item.Data).Free;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseDown(
    Sender : TObject;
    Button : TMouseButton;
    Shift  : TShiftState;
    X, Y   : Integer);
begin
    if ssLeft in Shift then begin
        FMouseDownPt := Point(X, Y);
        FMouseDownFlag := TRUE;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseMove(
    Sender : TObject;
    Shift  : TShiftState;
    X, Y   : Integer);
var
    Item     : TListItem;
    ColIndex : Integer;
begin
    FMouseMovePt := Point(X, Y);
    if not FMouseDownFlag then
        Exit;
    if not FDraggingImage then begin
        Item := ListViewMouseToItem(FMouseDownPt, ListView1, ColIndex);
        if Assigned(Item) then begin
            FDraggingImage := TRUE;
            Screen.Cursor  := crDrag;
            SetCaptureControl(ListView1);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.ListView1MouseUp(
    Sender : TObject;
    Button : TMouseButton;
    Shift  : TShiftState;
    X, Y   : Integer);
var
    Pt       : TPoint;
    ItemFrom : TListItem;
    ItemTo   : TListItem;
    ColIndex : Integer;
    LV       : TListView;
    IFrom    : Integer;
    ITo      : Integer;
    FileName : String;
begin
    FMouseDownFlag := FALSE;
    if FDraggingImage then begin
        FDraggingImage := FALSE;
        Screen.Cursor  := crDefault;
        SetCaptureControl(nil);
        LV       := Sender as TListView;
        ItemFrom := ListViewMouseToItem(FMouseDownPt, LV, ColIndex);
        ItemTo   := ListViewMouseToItem(Point(X, Y),  LV, ColIndex);
        IFrom    := ItemFrom.Index;
        FileName := TImageListViewItem(ItemFrom.Data).FileName;
        if not FileExists(FileName) then begin
            if Application.MessageBox(
                   PChar('File "' + FileName + '" doesn''t exist anymore' +
                         #10 + 'Remove from ListView ?'), 'WARNING',
                         MB_YESNO + MB_DEFBUTTON2) = IDYES then begin
                RemoveImage(IFrom);
                Exit;
            end;
        end;

        if Assigned(ItemTo) then begin
            // Drop inside of the pipe, move items around
            if ItemTo <> ItemFrom then begin
                ITo   := ItemTo.Index;
                MoveImage(IFrom, ITo);
            end;
        end
        else begin
            if PtInRect(LV.BoundsRect, Point(X, Y)) then begin
                // Drop on the listview but not on an item, just move at the end
                ITo := LV.Items.Count - 1;
                MoveImage(IFrom, ITo);
            end
            else begin
                // Drop outside of the ListView
                // Check if within Image1
                Pt := ListView1.ClientToScreen(Point(X, Y));
                Pt := Image1.ScreenToClient(Pt);
                if (Pt.X >= 0) and (Pt.X < Image1.Width) and
                   (Pt.Y >= 0) and (Pt.Y < Image1.Height) then begin
                    Image1.Picture.LoadFromFile(TImageListViewItem(ItemFrom.Data).FileName);
                end;
            end;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.AddImage(
    const FileName : String;
    BeforeIndex    : Integer);  // Index of the item where to insert (before)
var
    IFrom : Integer;
begin
    IFrom := AppendImage(FileName);
    if IFrom < 0 then
        Exit;            // Not found or already exist, not added
    if BeforeIndex = AtTopOfPipe then
        MoveImage(IFrom, 0)
    else if (BeforeIndex >= 0) and (BeforeIndex < ListView1.Items.Count) then
        MoveImage(IFrom, BeforeIndex);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Search if a give file already exists in list.
// Return -1 if not found
// Return item index if already in the list
function TDragDropMainForm.FindImage(const FileName: String): Integer;
begin
    for Result := 0 to ListView1.Items.Count - 1 do begin
        if SameText(FileName,
                    TImageListViewItem(ListView1.Items[Result].Data).FileName) then
            Exit;
    end;
    Result := -1;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.MoveImage(
    IFrom : Integer;
    ITo   : Integer);
var
    Data     : Pointer;
    Capt     : String;
    I        : Integer;
begin
    if IFrom < ITo then begin
        Data := ListView1.Items[IFrom].Data;
        Capt := ListView1.Items[IFrom].Caption;
        for I := IFrom to ITo - 1 do begin
            ListView1.Items[I].Data    := ListView1.Items[I + 1].Data;
            ListView1.Items[I].Caption := ListView1.Items[I + 1].Caption;
            TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
        end;
        ListView1.Items[ITo].Data    := Data;
        ListView1.Items[ITo].Caption := Capt;
        TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
    end
    else begin
        Data := ListView1.Items[IFrom].Data;
        Capt := ListView1.Items[IFrom].Caption;
        for I := IFrom downto ITo + 1 do begin
            ListView1.Items[I].Data    := ListView1.Items[I - 1].Data;
            ListView1.Items[I].Caption := ListView1.Items[I - 1].Caption;
            TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
        end;
        ListView1.Items[ITo].Data    := Data;
        ListView1.Items[ITo].Caption := Caption;
        TImageListViewItem(ListView1.Items[ITo].Data).Data := ListView1.Items[ITo];
    end;
    Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
    const FileName : String) : Boolean;
var
    Ext : String;
    I   : Integer;
begin
    Result := FALSE;
    Ext := ExtractFileExt(FileName);
    for I := Low(Exts) to High(Exts) do begin
        if SameText(Ext, Exts[I]) then begin
            Result := TRUE;
            Exit;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.KnownExtension(
    const FileNames : array of string) : Boolean;
var
    I : Integer;
begin
    Result := FALSE;
    for I := Low(FileNames) to High(FileNames) do begin
        if KnownExtension(FileNames[I]) then begin
            Result := TRUE;
            Exit;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Given a filename which could be a thumbnail filename, return either the
// filename unchanged or the image which is represented by thumbnail
function ReplaceThumb(const FileName : String) : String;
const
    ThSuffix = '.thumb.jpg';
var
    S : String;
    I : Integer;
begin
    if not SameText(Copy(FileName, Length(FileName) - Length(ThSuffix) + 1, 200),
                    ThSuffix) then begin
        Result := FileName;
        Exit;
    end;

    S := Copy(FileName, 1, Length(FileName) - Length(ThSuffix));
    for I := Low(Exts) to High(Exts) do begin
        Result := S + Exts[I];
        if FileExists(Result) then
            Exit;
    end;
    Result := FileName;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// ColIndex returns the column index, not the SubItem index.
function ListViewMouseToItem(
    Pt           : TPoint;
    LV           : TListView;
    var ColIndex : Integer): TListItem;
var
    Info : TLVHitTestInfo;
begin
//    Pt := LV.ScreenToClient(Mouse.Cursorpos);
    Result := LV.GetItemAt(Pt.X, Pt.Y);
    if Assigned(Result) then
        ColIndex := 0
    else begin
        FillChar(Info, SizeOf(Info), 0);
        Info.Pt := Pt;
        if LV.Perform(LVM_SUBITEMHITTEST, 0, LParam(@Info)) <> -1 then begin
            Result   := LV.Items[Info.iItem];
            ColIndex := Info.iSubItem;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDragDropMainForm.AppendImage(
    const FileName : String) : Integer;
var
    Item              : TListItem;
    ThumbnailFileName : String;
begin
    Result := -1;
    if not FileExists(FileName) then
        Exit;
    if FindImage(FileName) >= 0 then
        Exit;   // Already exist, do not add
    ThumbnailFileName := '';
    CreateThumbnail(FileName, ThumbnailFileName);
    Item         := ListView1.Items.Add;
    // Item.Caption is used as the hint
    Item.Caption := FileName;
    Item.Data    := TImageListViewItem.Create(FileName,
                                          ThumbnailFileName,
                                          Item,
                                          THUMBNAIL_SIZE,
                                          THUMBNAIL_SIZE);
    Result := Item.Index;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.RemoveImage(Index : Integer);
var
    I : Integer;
begin
    ListView1.Items.Delete(Index);
    for I := Index to ListView1.Items.Count - 1 do
        TImageListViewItem(ListView1.Items[I].Data).Data := ListView1.Items[I];
    Windows.InvalidateRect(ListView1.Handle, nil, FALSE);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDragDropMainForm.CreateThumbnail(
    const AFileName      : String;
    var   AThumbFileName : String);
var
    ThWidth          : Integer;
    ThHeight         : Integer;
    FTFile           : TDateTime;
    FTThumb          : TDateTime;
    Image            : IGPImage;
    Thumbnail        : IGPImage;
    Params           : IGPEncoderParameters;
    Quality          : Int32;
begin
    AThumbFileName := ChangeFileExt(AFileName, '.thumb.jpg');
    if FileExists(AThumbFileName) then begin
        // Thumbnail file must be dated AFTER original file so that it
        // is recreated when the original file is changed.
        FileAge(AFileName, FTFile);
        FileAge(AThumbFileName, FTThumb);
        if FTThumb >= FTFile then
            Exit;
    end;

    Image := TGPImage.Create(AFileName);

    // Thumbnail preserve original width/height ratio
    if Image.Width > Image.Height then begin
        ThWidth  := THUMBNAIL_SIZE;
        ThHeight := THUMBNAIL_SIZE * Image.Height div Image.Width;
    end
    else if Image.Width < Image.Height then begin
        ThHeight := THUMBNAIL_SIZE;
        ThWidth  := THUMBNAIL_SIZE * Image.Width div Image.Height;
    end
    else begin
        ThWidth  := THUMBNAIL_SIZE;
        ThHeight := THUMBNAIL_SIZE;
    end;

    Thumbnail := Image.GetThumbnailImage(ThWidth, ThHeight, nil, nil);
    Quality := 50;
    Params := TGPEncoderParameters.Create;
    Params.Add(EncoderQuality, Quality);
    Thumbnail.Save(AThumbFileName, TGPImageFormat.Jpeg, Params);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{ TImagePipeItem }

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TImageListViewItem.Create(
    const AFileName          : String;
    const AThumbnailFileName : String;
    const AItem              : TListItem;
    const AWidth             : Integer;
    const AHeight            : Integer);
var
    JpegImg : TJPEGImage;
    Ext     : String;
begin
    inherited Create;
    Data               := AItem;
    FileName           := AFileName;
    ThumbnailFileName  := AThumbnailFileName;
    Bitmap             := TBitMap.Create;
    if (AThumbnailFileName <> '') and (FileExists(AThumbnailFileName)) then begin
        Ext := ExtractFileExt(AThumbnailFileName);
        if SameText(Ext, '.jpg') then begin
            JpegImg := TJPEGImage.Create;
            try
                JpegImg.LoadFromFile(AThumbnailFileName);
                BitMap.Width  := JpegImg.Width;
                BitMap.Height := JpegImg.Height;
                BitMap.Canvas.Draw(0, 0, JpegImg);
            finally
                JpegImg.Destroy;
            end;
        end
        else if SameText(Ext, '.bmp') then
            Bitmap.LoadFromFile(AThumbnailFileName)
    end
    else begin
        Bitmap.Width       := AWidth - 4;
        Bitmap.Height      := AHeight - 4;
        Bitmap.PixelFormat := pf24bit;
        Bitmap.Canvas.MoveTo(0, 0);
        BitMap.Canvas.LineTo(Bitmap.Width, Bitmap.Height);
        Bitmap.Canvas.MoveTo(Bitmap.Width, 0);
        BitMap.Canvas.LineTo(0, Bitmap.Height);
        BitMap.Canvas.LineTo(0, 0);
        BitMap.Canvas.LineTo(Bitmap.Width - 1, 0);
        BitMap.Canvas.LineTo(Bitmap.Width - 1, Bitmap.Height - 1);
        BitMap.Canvas.LineTo(0, Bitmap.Height - 1);
        Bitmap.Canvas.TextOut(4, 4, AFileName);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TImageListViewItem.Destroy;
begin
    FreeAndNil(Bitmap);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.

Download source code from: http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html
Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

Programmer picks: 7 must-try mobile dev tools

InfoWorld has selected Embarcadero RAD Studio XE4 in his slideshow about mobile dev tools. Established companies like Intel and Embarcadero Technologies, as well as lesser-known players are continually rolling out technologies to help meet mobile developers' needs.

Read the full article at: http://www.infoworld.com/slideshow/101586/programmer-picks-7-must-try-mobile-dev-tools-218867#slide6


Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

Internet Explorer Automation Part 4

I this article, I will explain how to extract statistics from Blogger stats page. This follows the previous article in which you learned how to automate the login process and get the stats page.

The stats page is organized in a number of HTML elements. The one which is interesting for us is a table. Since there are many tables in the page, I had to find out a way to detect the correct one, even if the page layout changes.

The idea is to enumerate all the HTML elements in the page, check for the table tag and check the labels against string constants. This is easy since the table is organized in two columns, one with the label and one with the number.

To iterate all the HTML elements is easy. As we saw in previous article, there is a property of the HTML document which is a collection (a kind of array) name “all”. It is enough to enumerate it and for each item in the collection query the interface IID_IHTMLElement to get hand on the HTML element.

Having the HTML element, we can check the tagName property which is actually the tag type. We are looking for ‘Table’. If it is a table, we get the innertext property which as its name implies is the raw text inside the tag. Raw text means it is the text without any embedded tags. In the case of an HTML table, we get the content of all table cells. We will search that text for the labels such as “Pageviews today” and then extract the number just after. For that purpose I wrote a little utility function I will show you in a moment.

Here is the code to do what I’ve just described:

    Coll := FHtmlDoc.all;
    for I := 0 to Coll.Length - 1 do begin
        pDisp := Coll.item(I, var2);
        if pDisp.QueryInterface(IID_IHTMLElement, HtmlElem) = S_OK then begin
            if SameText(HtmlElem.tagName, 'TABLE') then begin
                Txt := String(HtmlElem.innertext);
                if not ExtractNumberAfterText(Txt, TxtToday,
                                              CountToday) then
                    continue;
                if not ExtractNumberAfterText(Txt, TxtYesterday,
                                              CountYesterday) then
                    continue;
                if not ExtractNumberAfterText(Txt, TxtLastMonth,
                                              CountLastMonth) then
                    continue;
                if not ExtractNumberAfterText(Txt, TxtAllTime,
                                              CountAllTime) then
                    continue;

                Buf := AnsiString(
                          FormatDateTime('YYYY/MM/DD;HH:NN:SS;', Now) +
                          '"_' + FBlogId + '";' +
                          IntToStr(CountToday) + ';' +
                          IntToStr(CountYesterday) + ';' +
                          IntToStr(CountLastMonth) + ';' +
                          IntToStr(CountAllTime));
                Result := TRUE;
                break;
            end;
        end;
    end;

The utility function ExtractNumberAfterText is rather simple. It is just simple Delphi code to parse the string. We just have to pay attention to skip all spaces and line breaks because they are not significant in HTML.

function ExtractNumberAfterText(
    const Source : String;
    const Text   : String;
    out   Number : Integer) : Boolean;
var
    J : Integer;
begin
    Result := FALSE;
    Number := 0;
    J := Pos(Text, Source);
    if J <= 0 then
        Exit;
    // Search for first digit right after searched text,
    // ignore anything not a digit
    J := J + Length(Text);
    while (J <= Length(Source)) and
          (not CharInSet(Source[J], ['0'..'9'])) do
        Inc(J);
    // After first digit, scan all digit and ',' or '.' (which
    // are used as thousand separator (Depends on language, any will do)
    repeat
        // If we have a digit, use it to build the final number
        if CharInSet(Source[J], ['0'..'9']) then
            Number := Number * 10 + Ord(Source[J]) - Ord('0');
        Inc(J);
    until (J > Length(Source)) or
          (not CharInSet(Source[J], ['0'..'9', ',', '.']));
    Result := TRUE;
end;

About the design of the application

I explained how to automate Internet Explorer. I showed the actual code used. But I didn’t gave any explanation about how I have designed the whole application.

I always like to separate the user interface from data processing. For that purpose, I created two source files: one with the user interface and one with a class having the automation code.

My user interface is very basic: a simple form with a memo showing messages about what is going on. I could as well write a console mode application or a service application. This doesn’t really matters.

My data processing code is encapsulated in a class I named TQueryBloggerStatistics. It explains what it does. The class is a kind of container. It exposes a few methods and properties to permit what has to be done with that kind of automation.

The class declaration is as follow:

    TQueryBloggerStatistics = class
    private
        FWebBrowser   : IWebBrowser2;
        FBlogID       : String;
        FUserEMail    : String;
        FUserPassword : String;
        FLogFileName  : String;
        FVisible      : Boolean;
        FOnDisplay    : TDisplayEvent;
        function WaitComplete(const URL : String = ''): IHTMLDocument2;
        function FindTag(const Coll    : IHTMLElementCollection;
                         const TagName, TagID: String): IHTMLElement;
        procedure Display(const Msg : String);
    public
        constructor Create;
        function  Execute : Boolean;
        procedure Quit;
        procedure LoadConfig(const IniFileName : String); overload;
        procedure LoadConfig; overload;
        function  SaveConfig(const IniFileName: String) : Boolean; overload;
        function  SaveConfig : Boolean; overload;
        property  BlogID       : String        read  FBlogID
                                               write FBlogID;
        property  UserEMail    : String        read  FUserEMail
                                               write FUserEMail;
        property  UserPassword : String        read  FUserPassword
                                               write FUserPassword;
        property  LogFileName  : String        read  FLogFileName
                                               write FLogFileName;
        property  Visible      : Boolean       read  FVisible
                                               write FVisible;
        property  OnDisplay    : TDisplayEvent read  FOnDisplay
                                               write FOnDisplay;
    end;

I won’t reproduce the implementation here because I already showed most interesting part. You can download the full source code for the class and the complete demo application from my website at:
http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

Previous article: http://francois-piette.blogspot.be/2013/05/internet-explorer-automation-part-3.html

Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

Pascal still an advantage for some iOS, Android developers

Just read this article. It could also interest you so I share it:
http://www.zdnet.com/pascal-still-an-advantage-for-some-ios-android-developers-7000014743/


Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be

OpenSource GDI+ Library - Part 2

In a previous article, I talked about OpenSource GDI+ Library for Delphi. In this article I will present a small application which is the basic of an image processing or image drawing application.

A form to display an image

The application is divided into two forms. One main form and one image display form. The main form creates two instances of the image display form to show two images side by side. The image display forms are created as parented, that is they appears as a child window of the main form.

The most interesting part of the code, involving GDI+ Library is into the image display form. Beside displaying an image, the display form expose a small API to manipulate the image. The main form is very simple and provides a user interface for the display form API.

In this demo, the API is quite simple. It provides zoom and pan and a trivial paint of something above the image. Nevertheless, the code is really serious and you can easily start your own image processing or drawing application.

The display form actually display a bitmap loaded from a file using GDI+ decoders. You can load JPG, GIF, TIF and other format. You could as well create the bitmap from an image capture device such a camera or a scanner. This bitmap is named "FullBitmap" in the code.

The bitmap is drawn into a second bitmap which will be used for display. On this second bitmap the application could paint or draw anything. In this demo, it paints only a simple text but in a real application, you could - for example - have a data structure representing geometrical items and draw those items. You'll get a drawing program. This second bitmap is named "ViewBitmap" in the code.

To create zoom and pan, I used GDI+ built in coordinate transformations and a bunch of variables describing the zoom and pan.

GDI+ also provide a clipping function that I used to make sure the displayed image, zoomed and panned is not drawn outside of the viewing area.

Finally, the display form also display a border around the image. It is used when multiple images are displayed on the same window. The "active" image has his border drawn in a different color.

Below you'll find full source code for your reference. It is also available for download as a full project from my website at:
     http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

unit ImageDisplay;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics,
    Controls, ExtCtrls, Forms, Dialogs, GdiPlus;

const
    WM_APP_PAINT      = WM_USER + 1;
    DEMO_FILE         = '..\..\ics_logo.gif';

type
    TImageForm = class(TForm)
    private
        FFrameWidth              : Integer;
        FFrameHeight             : Integer;
        FPaintTop                : Integer;
        FPaintLeft               : Integer;
        FPaintMargin             : Integer;
        FPaintHeight             : Integer;
        FPaintWidth              : Integer;
        FYTop                    : Integer;
        FXLeft                   : Integer;
        FZoomFactor              : Double;    // 1.0 = no zoom
        FFullBitMap              : IGPBitmap;
        FViewBitmap              : IGPBitmap;
        FMarginColor             : TColor;
        FAppPaintFlag            : Boolean;
        function CreateGraphicInterface: IGPGraphics;
        procedure PaintSomething(Graphics: IGPGraphics);
    protected
        procedure Paint; override;
        procedure Resize; override;
        procedure InitDrawingArea(ALeft, ATop, AWidth, AHeight, AMargin: Integer);
        procedure TriggerAppPaint;
        procedure WMAppPaint(var Msg: TMessage); message WM_APP_PAINT;
        procedure SetMarginColor(const Value: TColor);
        function  ZoomFitCompute: Double;
    public
        constructor Create(AOwner : TComponent); override;
        procedure ZoomIn(Speed: Double);
        procedure ZoomOut(Speed: Double);
        procedure PanRight;
        procedure PanDown;
        procedure PanLeft;
        procedure PanUp;
        procedure PanCenter;
        function LoadFromFile(const AFileName: String): Boolean;
        property MarginColor        : TColor    read  FMarginColor
                                                write SetMarginColor;
    end;

var
  ImageForm: TImageForm;

implementation

{$R *.dfm}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TImageForm.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    FZoomFactor              := 1.0;
    InitDrawingArea(0, 0, Width, Height, 0);
    if FileExists(DEMO_FILE) then
        LoadFromFile(DEMO_FILE);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TImageForm.LoadFromFile(const AFileName : String) : Boolean;
begin
    FFullBitMap      := TGPBitmap.Create(AFileName);
    FFrameWidth      := FFullBitMap.Width;
    FFrameHeight     := FFullBitMap.Height;
    FViewBitmap      := TGPBitmap.Create(FFrameWidth, FFrameHeight,
                                         PixelFormat24bppRGB);
    TriggerAppPaint;
    Result           := TRUE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TImageForm.CreateGraphicInterface : IGPGraphics;
begin
    Result := TGPGraphics.Create(Canvas.Handle);
    Result.ResetTransform;
    Result.TranslateTransform(FPaintLeft + FXLeft, FPaintTop + FYTop,
                              MatrixOrderPrepend);
    Result.ScaleTransform(FZoomFactor, FZoomFactor, MatrixOrderPrepend);
    Result.InterpolationMode := InterpolationModeHighQualityBilinear;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.Paint;
var
    Graphics         : IGPGraphics;
    ViewGraphics     : IGPGraphics;
    Points           : array [0..4] of TGPPoint;
    WorldPoints      : array [0..1] of TGPPoint;
    WorldDrawingArea : TGPRect;
    WorldBitmapArea  : TGPRect;
begin
    FAppPaintFlag := FALSE;
    Graphics := CreateGraphicInterface;
    if Assigned(FFullBitMap) then begin
        Points[0].X := 0;
        Points[0].Y := 0;
        Points[1].X := FFullBitMap.Width;
        Points[1].Y := FFullBitMap.Height;
        Points[2].X := FPaintWidth;
        Points[2].Y := FPaintHeight;
        Points[3].X := FXLeft;
        Points[3].Y := FYTop;
        Points[4].X := FPaintLeft;
        Points[4].Y := FPaintTop;
        Graphics.TransformPoints(CoordinateSpaceWorld,   // Destination
                                 CoordinateSpaceDevice,  // Source
                                 Points);

        // World coordinate space are simply bitmap coordinate space
        WorldBitmapArea.X       := 0;
        WorldBitmapArea.Y       := 0;
        WorldBitmapArea.Width   := FFullBitMap.Width;
        WorldBitmapArea.Height  := FFullBitMap.Height;

        WorldDrawingArea.X      := Points[0].X - Points[3].X;
        WorldDrawingArea.Y      := Points[0].Y - Points[3].Y;
        WorldDrawingArea.Width  := (Points[2].X - Points[3].X) - WorldDrawingArea.X;
        WorldDrawingArea.Height := (Points[2].Y - Points[3].Y) - WorldDrawingArea.Y;

        Graphics.SetClip(WorldDrawingArea);

        ViewGraphics := TGPGraphics.FromImage(FViewBitMap);
        ViewGraphics.DrawImage(FFullBitMap, 0, 0, FFrameWidth, FFrameHeight);

        PaintSomething(ViewGraphics);

        Graphics.DrawImage(FViewBitMap, 0, 0, FFrameWidth, FFrameHeight);

        // Draw the rectangle surrounding the image.
        WorldPoints[0].X := 0;
        WorldPoints[0].Y := 0;
        WorldPoints[1].X := FFullBitMap.Width;
        WorldPoints[1].Y := FFullBitMap.Height;
        Graphics.TransformPoints(CoordinateSpaceDevice,   // Destination
                                 CoordinateSpaceWorld,    // Source
                                 WorldPoints);
    end
    else begin
        // FFullBitmap not assigned
        WorldPoints[0].X := 0;
        WorldPoints[0].Y := 0;
        WorldPoints[1].X := 0;
        WorldPoints[1].Y := 0;
    end;

    Canvas.Pen.Style   := psClear;
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := Color;
    // Left
    Canvas.Rectangle(0, 0,
                     WorldPoints[0].X + 1, FPaintHeight + 1);
    // Right
    Canvas.Rectangle(WorldPoints[1].X, 0,
                     FPaintWidth + 1, FPaintHeight + 1);
    // Top
    Canvas.Rectangle(WorldPoints[0].X, 0,
                     WorldPoints[1].X + 1, WorldPoints[0].Y + 1);
    // Bottom
    Canvas.Rectangle(WorldPoints[0].X, WorldPoints[1].Y,
                     WorldPoints[1].X + 1, FPaintHeight + 1);

    // Paint margin area (used to show selected image)
    Canvas.Pen.Style   := psSolid;
    Canvas.Pen.Color   := FMarginColor;
    Canvas.Pen.Width   := FPaintMargin;
    Canvas.MoveTo(FPaintMargin div 2, FPaintMargin div 2);
    Canvas.LineTo(FPaintWidth + 1, FPaintMargin div 2);
    Canvas.LineTo(FPaintWidth + 1, FPaintHeight + 1);
    Canvas.LineTo(FPaintMargin div 2, FPaintHeight + 1);
    Canvas.LineTo(FPaintMargin div 2,  0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.InitDrawingArea(
    ALeft, ATop, AWidth, AHeight, AMargin : Integer);
begin
    FPaintMargin := AMargin;
    FPaintTop    := ATop + AMargin;
    FPaintLeft   := ALeft + AMargin;
    FPaintWidth  := AWidth  - ALeft - AMargin;
    FPaintHeight := AHeight - ATop  - AMargin;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.Resize;
var
    NewXLeft, NewYTop : Integer;
begin
    InitDrawingArea(0, 0, ClientWidth, ClientHeight, 2);
    NewXLeft := (FPaintWidth  - Round(FFrameWidth  * FZoomFactor)) div 2;
    NewYTop  := (FPaintHeight - Round(FFrameHeight * FZoomFactor)) div 2;
    if NewXLeft > 0 then
        FXLeft := NewXLeft;
    if NewYTop > 0 then
        FYTop := NewYTop;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.WMAppPaint(var Msg: TMessage);
begin
    Paint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.TriggerAppPaint;
begin
    // To avoid too much repainting, we use a flag and a custom message.
    // The custom message will trigger the painting.
    // Once the custom message has been posted, the falg is set and no more
    // message will be posted until the flag is reset by the paint routine.
    if not FAppPaintFlag then begin
        FAppPaintFlag := TRUE;
        PostMessage(Handle, WM_APP_PAINT, 0, 0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.SetMarginColor(const Value: TColor);
begin
    FMarginColor := Value;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.ZoomOut(Speed : Double);
begin
    if Abs(Speed) < 0.001 then
        FZoomFactor := ZoomFitCompute
    else if Speed < 0 then
        FZoomFactor := -Speed
    else
        FZoomFactor := FZoomFactor / 1.05;
    if FZoomFactor < 0.01 then
        FZoomFactor := 0.01;
    if Abs(FZoomFactor - 1.0) < 0.001 then
        FZoomFactor := 1.0; // Avoid cumulating error
    //TriggerZoomChange(FZoomFactor);
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.ZoomIn(Speed : Double);
begin
    if Abs(Speed) < 0.001 then
        FZoomFactor := ZoomFitCompute
    else if Speed < 0 then
        FZoomFactor := -Speed
    else
        FZoomFactor := FZoomFactor * Speed;
    if Abs(FZoomFactor - 1.0) < 0.001 then
        FZoomFactor := 1.0; // Avoid cumulating error
    //TriggerZoomChange(FZoomFactor);
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TImageForm.ZoomFitCompute : Double;
var
    Z1, Z2 : Double;
begin
    if (FFrameWidth = 0) or (FFrameHeight = 0) then begin
        Result := 1.0;
        FXLeft := 0;
        FYTop  := 0;
        Exit;
    end;
    Z1 := FPaintWidth  / FFrameWidth;
    Z2 := FPaintHeight / FFrameHeight;
    if Z1 < Z2 then
        Result := Z1 * 0.95
    else
        Result := Z2 * 0.95;

    FXLeft := (FPaintWidth  - Round(FFrameWidth  * Result)) div 2;
    FYTop  := (FPaintHeight - Round(FFrameHeight * Result)) div 2;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PanRight;
begin
    FXLeft := FXLeft + 10;
    FYTop  := FYTop  + 0;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PanLeft;
begin
    FXLeft := FXLeft - 10;
    FYTop  := FYTop  + 0;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PanUp;
begin
    FXLeft := FXLeft + 0;
    FYTop  := FYTop  - 10;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PanDown;
begin
    FXLeft := FXLeft + 0;
    FYTop  := FYTop  + 10;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PanCenter;
begin
    FXLeft := (FPaintWidth  - Round(FFrameWidth  * FZoomFactor)) div 2;
    FYTop  := (FPaintHeight - Round(FFrameHeight * FZoomFactor)) div 2;
    TriggerAppPaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TImageForm.PaintSomething(Graphics: IGPGraphics);
var
    FontFamily : IGPFontFamily;
    Font       : IGPFont;
    Point      : TGPPointF;
    SolidBrush : IGPBrush;
begin
    FontFamily := TGPFontFamily.Create('Times New Roman');
    Font       := TGPFont.Create(FontFamily, 24, FontStyleRegular, UnitPixel);
    SolidBrush := TGPSolidBrush.Create(TGPColor.Create(255, 255, 0, 0));
    Point.Initialize(10, 10);
    Graphics.TextRenderingHint := TextRenderingHintAntiAlias;
    Graphics.DrawString('Delphi rocks!', Font, Point, SolidBrush);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.

Using TImageForm

The form we saw above is used twice in the sample application to display two images side by side. The form has 3 panels: a top panel acting as a tool bar and two panels below for the two images.

The tool bar has been made very simple: only basic buttons to call the image display form API on behalf of the active image. It's up to you to use a nice user interface, you've got the idea.

The two image panels are use to host a display form. Each one showing his independent image.

Finally, an OpenDialog is used to load an image from a file. You can easily add the code to save an image as well since GDI+ does all the work for you.

unit ImageMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, ImageDisplay, Vcl.ExtCtrls, Vcl.StdCtrls;

type
    TMainForm = class(TForm)
        TopPanel: TPanel;
        LeftPanel: TPanel;
        Splitter1: TSplitter;
        RightPanel: TPanel;
        ZoomFitButton: TButton;
        ZoomInButton: TButton;
        ZoomOutButton: TButton;
        PanLeftButton: TButton;
        PanRightButton: TButton;
        PanUpButton: TButton;
        PanDownButton: TButton;
        PanCenterButton: TButton;
        Zoom100Button: TButton;
        OpenButton: TButton;
        OpenDialog1: TOpenDialog;
        procedure LeftPanelResize(Sender: TObject);
        procedure RightPanelResize(Sender: TObject);
        procedure ZoomFitButtonClick(Sender: TObject);
        procedure ZoomInButtonClick(Sender: TObject);
        procedure ZoomOutButtonClick(Sender: TObject);
        procedure PanLeftButtonClick(Sender: TObject);
        procedure PanRightButtonClick(Sender: TObject);
        procedure PanUpButtonClick(Sender: TObject);
        procedure PanDownButtonClick(Sender: TObject);
        procedure PanCenterButtonClick(Sender: TObject);
        procedure Zoom100ButtonClick(Sender: TObject);
        procedure OpenButtonClick(Sender: TObject);
    private
        FLeftImage   : TImageForm;
        FRightImage  : TImageForm;
        FActiveImage : TImageForm;
        procedure SetActiveImage(Image : TImageForm);
        procedure ImageClick(Sender: TObject);
    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;
    end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{ TMainForm }

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TMainForm.Create(AOwner: TComponent);
begin
    inherited Create(Aowner);
    FLeftImage              := TImageForm.CreateParented(LeftPanel.Handle);
    FLeftImage.BorderStyle  := bsNone;
    FLeftImage.OnClick      := ImageClick;
    FLeftImage.Visible      := TRUE;

    FRightImage             := TImageForm.CreateParented(RightPanel.Handle);
    FRightImage.BorderStyle := bsNone;
    FRightImage.OnClick     := ImageClick;
    FRightImage.Visible     := TRUE;

    // Unselect active image and select left image as active
    // It will set the image borders correctly
    SetActiveImage(nil);
    SetActiveImage(FLeftImage);

    // Call resize handler for both panels to set images display size
    LeftPanelResize(LeftPanel);
    RightPanelResize(LeftPanel);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TMainForm.Destroy;
begin
    FreeAndNil(FLeftImage);
    FreeAndNil(FRightImage);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.LeftPanelResize(Sender: TObject);
begin
    if Assigned(FLeftImage) then
        FLeftImage.BoundsRect := Rect(0, 0,
                                      LeftPanel.Width - 1,
                                      LeftPanel.Height - 1);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.OpenButtonClick(Sender: TObject);
begin
    if not Assigned(FActiveImage) then
        SetActiveImage(FLeftImage);
    OpenDialog1.Filter     :=  'JPEG images (*.jpg)|*.jpg|' +
                               'TIFF images (*.tif)|*.tif|' +
                               'BMP images (*.bmp)|*.bmp|' +
                               'GIF images (*.gif)|*.gif|' +
                               'PNG images (*.png)|*.png|' +
                               'All files (*.*)|*.*|' +
                               '';
//    OpenDialog1.InitialDir := FInitialDir;
    OpenDialog1.Options    := OpenDialog1.Options + [ofPathMustExist,
                                                     ofFileMustExist];
    if not OpenDialog1.Execute(Handle) then
        Exit;

    FActiveImage.LoadFromFile(OpenDialog1.FileName);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.RightPanelResize(Sender: TObject);
begin
    if Assigned(FRightImage) then
        FRightImage.BoundsRect := Rect(0, 0,
                                       RightPanel.Width - 1,
                                       RightPanel.Height - 1);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.SetActiveImage(Image: TImageForm);
begin
    if not Assigned(Image) then begin
        FLeftImage.MarginColor  := Color;
        FRightImage.MarginColor := Color;
    end
    else begin
        if Assigned(FActiveImage) then
            FActiveImage.MarginColor := Color;
        FActiveImage := Image;
        FActiveImage.MarginColor := clBlack;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.ImageClick(Sender: TObject);
begin
    SetActiveImage(Sender as TImageForm);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.Zoom100ButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.ZoomIn(-1.0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.ZoomFitButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.ZoomIn(0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.ZoomInButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.ZoomIn(1.05);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.ZoomOutButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.ZoomOut(1.05);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.PanCenterButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.PanCenter;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.PanDownButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.PanDown;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.PanLeftButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.PanLeft;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.PanRightButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.PanRight;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMainForm.PanUpButtonClick(Sender: TObject);
begin
    if Assigned(FActiveImage) then
        FActiveImage.PanUp;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.

Read previous article at:
    http://francois-piette.blogspot.be/2013/05/opensource-gdi-library.html
This article is available from:
    http://francois-piette.blogspot.be/2013/05/opensource-gdi-library-part-2.html
Download source code at:
     http://www.overbyte.be/frame_index.html?redirTo=/blog_source_code.html

Follow me on Twitter
Follow me on LinkedIn
Follow me on Google+
Visit my website: http://www.overbyte.be