Capturing keyboard messages at application level

Problem/Question/Abstract:

We can migrate old DOS applications to the Windows environment, but frequently we can't migrate the users :)

Answer:

We capture the keyboard messages with the OnMessage event of the Application object. You can find similar articles, but the code presented here is more complete and takes into account certain special cases.

For the ENTER key (VK_RETURN) we want to move to the next control in the case of edit boxes and other controls, so we ask if the active control descends from TCustomEdit, which includes TEdit, TDBEdit, TMaskEdit, TDBMaskEdit, TMemo, TDBMemo and other components provided by third parties. Since we want to exclude TMemo, TDBMemo and, in general, all descendants of TCustomMemo, we make a special proviso in this case (leaving the message unchanged with no action), leaving us with the single-line edit controls, to which we add listboxes, comboxes, etc. For these elements we replace the ENTER key (VK_RETURN) by a TAB key (VK_TAB), both for the WM_KEYDOWN and WM_KEYUP events.

However in the case of a combobox (any TCustomCombobox descendant), when the list is dropped down we wish to maintain the traditional behaviour of the ENTER key (i.e. closing the list).

It would be nice to have a keyboard shortcut for the default button of a form (the button with its Default property set to True), for example CTRL+ENTER. This feature is included in the code. The way it is accomplished is a little bit complex to explain... Perhaps it would have been easier to iterate thru the components on a form to find a focuseable button with Default = True, and then call its Click method, but we used a code similar to the one used in VCL forms, which takes into account the fact that the ENTER key might be wanted to get trapped by many controls, not only a button.

We also want the DOWN arrow key (VK_DOWN) to be mapped as a TAB key (VK_TAB). For this case we used a simpler code. Of course, we also want the UP arrow key (VK_UP) to be mapped to a SHIFT+TAB key combination. Well, it isn't possible to map a key with a modifier. We can descard the key and simulate the events of pressing SHIFT and then TAB, or we can change the state of the SHIFT key in the keyboard state array (like we did with the CTRL key in the CTRL+ENTER combination), but we took a different approach (simply focusing the previous control of the active control in the tab order).

Finally, for Spanish applications, it is usually desirable to replace the decimal point of the numeric keypad with a coma (decimal separator in Spanish).

Well, enough talking, and here's the code:

type
  TForm1 = class(TForm)
    ...
    private
    ...
      procedure ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
    ...
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := ApplicationMessage;
end;

procedure TForm1.ApplicationMessage(var Msg: TMsg;
  var Handled: Boolean);
var
  ActiveControl: TWinControl;
  Form: TCustomForm;
  ShiftState: TShiftState;
  KeyState: TKeyboardState;
begin
  case Msg.Message of
    WM_KEYDOWN, WM_KEYUP:
      case Msg.wParam of
        VK_RETURN:
          // Replaces ENTER with TAB, and CTRL+ENTER with ENTER...
          begin
            GetKeyboardState(KeyState);
            ShiftState := KeyboardStateToShiftState(KeyState);
            if (ShiftState = []) or (ShiftState = [ssCtrl]) then
            begin
              ActiveControl := Screen.ActiveControl;
              if (ActiveControl is TCustomComboBox) and
                (TCustomComboBox(ActiveControl).DroppedDown) then
              begin
                if ShiftState = [ssCtrl] then
                begin
                  KeyState[VK_LCONTROL] := KeyState[VK_LCONTROL] and $7F;
                  KeyState[VK_RCONTROL] := KeyState[VK_RCONTROL] and $7F;
                  KeyState[VK_CONTROL] := KeyState[VK_CONTROL] and $7F;
                  SetKeyboardState(KeyState);
                end;
              end
              else if (ActiveControl is TCustomEdit)
                and not (ActiveControl is TCustomMemo)
                or (ActiveControl is TCustomCheckbox)
                or (ActiveControl is TRadioButton)
                or (ActiveControl is TCustomListBox)
                or (ActiveControl is TCustomComboBox)
                {// You can add more controls to the list with "or" } then
                if ShiftState = [] then
                begin
                  Msg.wParam := VK_TAB
                end
                else
                begin // ShiftState = [ssCtrl]
                  Msg.wParam := 0; // Discard the key
                  if Msg.Message = WM_KEYDOWN then
                  begin
                    Form := GetParentForm(ActiveControl);
                    if (Form <> nil) and
                      (ActiveControl.Perform(CM_WANTSPECIALKEY,
                      VK_RETURN, 0) = 0) and
                      (ActiveControl.Perform(WM_GETDLGCODE, 0, 0)
                      and DLGC_WANTALLKEYS = 0) then
                    begin
                      KeyState[VK_LCONTROL] := KeyState[VK_LCONTROL] and $7F;
                      KeyState[VK_RCONTROL] := KeyState[VK_RCONTROL] and $7F;
                      KeyState[VK_CONTROL] := KeyState[VK_CONTROL] and $7F;
                      SetKeyboardState(KeyState);
                      Form.Perform(CM_DIALOGKEY, VK_RETURN, Msg.lParam);
                    end;
                  end;
                end;
            end;
          end;
        VK_DOWN:
          begin
            GetKeyboardState(KeyState);
            if KeyboardStateToShiftState(KeyState) = [] then
            begin
              ActiveControl := Screen.ActiveControl;
              if (ActiveControl is TCustomEdit)
                and not (ActiveControl is TCustomMemo)
                {// You can add more controls to the list with "or" } then
                Msg.wParam := VK_TAB;
            end;
          end;
        VK_UP:
          begin
            GetKeyboardState(KeyState);
            if KeyboardStateToShiftState(KeyState) = [] then
            begin
              ActiveControl := Screen.ActiveControl;
              if (ActiveControl is TCustomEdit)
                and not (ActiveControl is TCustomMemo)
                {// You can add more controls to the list with "or" } then
              begin
                Msg.wParam := 0; // Discard the key
                if Msg.Message = WM_KEYDOWN then
                begin
                  Form := GetParentForm(ActiveControl);
                  if Form <> nil then // Move to previous control
                    Form.Perform(WM_NEXTDLGCTL, 1, 0);
                end;
              end;
            end;
          end;
        // Replace the decimal point of the numeric key pad (VK_DECIMAL)
        // with a comma (key code = 188). For Spanish applications.
        VK_DECIMAL:
          begin
            GetKeyboardState(KeyState);
            if KeyboardStateToShiftState(KeyState) = [] then
            begin
              Msg.wParam := 188;
            end;
          end;
      end;
  end;
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

FTP Server demo with Indy components

Problem/Question/Abstract:

Make FTP server.

Answer:

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer,idftplist,
  IdUserAccounts, StdCtrls;

  public
    function WindowsDirFixup(APath:String):String;
    { Public declarations }
  end;

var
  Form1: TForm1;
pRoot:string; //program directory.

implementation
uses JCLFileUtils;
{$R *.dfm}

function TForm1.WindowsDirFixup(APath:String):String;
var s:string;

  function ReplaceStr(const S, Srch, Replace: string): string;
  var
    I: Integer;
    Source: string;
  begin
    Source := S;
    Result := '';
    repeat
      I := Pos(Srch, Source);
      if I > 0 then begin
        Result := Result + Copy(Source, 1, I - 1) + Replace;
        Source := Copy(Source, I + Length(Srch), MaxInt);
      end
      else Result := Result + Source;
    until I <= 0;
  end;

begin
  s := ReplaceStr(APath,'/','\');
  s := ReplaceStr(s,'\\','\');
  Result := s;
end;


procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
  const APath: String; ADirectoryListing: TIdFTPListItems);
var Li :TIdFTPListItem;
    SRec : TSearchRec;
    a : word;
begin
  ADirectorylisting.DirectoryName :=Apath;
  ADirectorylisting.ListFormat:=flfdos;
  memo1.lines.add(apath);
//  a := FindFirst(pRoot+APath+'\*.*',$31,Srec); //ignore hidden/system files.
  a := FindFirst(pRoot+APath+'\*.*',faAnyFile        ,Srec); //all files.
  While a =0 do
  begin
    li := ADirectoryListing.Add;
    li.FileName := SRec.Name;
    li.Size := SRec.Size;
    li.ModifiedDate := FileDateToDateTime(SRec.Time);
    if (SRec.Attr and $10) > 0 then
      li.ItemType   := ditDirectory
      else
       li.ItemType   := ditFile;
    a := FindNext(SRec);
  end;
  FindClose(SRec);
//  SysUtils.SetCurrentDir(pRoot+APath+'\..'); //Release dir, so it can be deleted, possibly
end;


procedure TForm1.IdFTPServer1Disconnect(AThread: TIdPeerThread);
begin
    athread.Terminate;
end;

procedure TForm1.IdFTPServer1AfterUserLogin(ASender: TIdFTPServerThread);
begin
asender.CurrentDir:='c:\';
asender.HomeDir:='c:\';
end;

procedure TForm1.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin
begin
  if not ForceDirectories(WindowsDirFixup(pRoot+Vdirectory)) then
  begin
//    Raise Exception.Create('Could not create directory');
  end;
end;

end;

procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
  const AFileName: String; var VStream: TStream);
begin
try
  VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenRead);
  except
  end;
end;


procedure TForm1.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
begin
//ASender.CurrentDir :=ASender.CurrentDir+Vdirectory;//'/';
if vdirectory='..\' then vdirectory:=ASender.CurrentDir+'\..\';
//if vdirectory='../' then vdirectory:='c:';
ASender.CurrentDir :=Vdirectory;//'/';
  memo1.lines.add('Changedir: '+vdirectory);

end;

procedure TForm1.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
  const AFileName: String; AAppend: Boolean; var VStream: TStream);
begin
  if not Aappend then
    VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmCreate)
   else
      VStream := TFileStream.Create(WindowsDirFixup(pRoot+AFilename),fmOpenWrite)
end;


procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
  const AFilename: String; var VFileSize: Int64);
  var s:string;
  begin
  s := WindowsDirFixup(pRoot+AFilename);
  try
  If FileExists(s) then
    VFileSize :=  GetSizeofFile(S)
    else VFileSize := 0;
  except
    VFileSize := 0;
  end;
end;



procedure TForm1.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
  const APathName: String);
begin
  DeleteFile(WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+APathname));
end;


procedure TForm1.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
  var VDirectory: String);
var s:String;

begin
  s := WindowsDirFixup(pRoot+Vdirectory);
  if DirectoryExists(s) then
  begin
    SetCurrentDir(s+'\..\'); //get out of dir. so it can be deleted.
  if not DelTree(s) then //dir and all files.
  if not RemoveDir(s) then ;//
  begin
//    Raise Exception.Create('Could not remove directory');
  end;
  end;

end;

procedure TForm1.IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
  const ARenameFromFile, ARenameToFile: String);
var sf,st:String;
begin
  sf := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameFromFile);
  st := WindowsDirFixup(pRoot+ASender.CurrentDir+'\'+ARenameToFile);
  if not Renamefile(sf,st) then
  begin
    Raise Exception.Create('Could not rename file');
  end;

end;

How to retrieve cell values of a TDBGrid using MouseCoord

Problem/Question/Abstract:

I want to display a help window containing the value of the data cell under the cursor.

Answer:

The trick is to use the protected DataLink property of TDBGrid which is of typeTGridDataLink. One can see that property as being kind of a buffer for a displayed page in TDBGrid. Take note that I'm using D6 and that I used OnMouseMove. Delphi6's TDBGrid has a OnMouseMove event whereas D4 has not (I don't know about D5). If you are using D4, you can hack the OnMouseMove event which comes from TControl.


type
  THackDbGrid = class(TDBGrid);

procedure TForm1.DBGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  gc: TGridCoord;
  dbg: TDBGrid;
  SavedActiveRec: integer;
begin
  dbg := TDBGrid(Sender);
  gc := dbg.MouseCoord(X, Y);
  if (gc.X > 0) and (gc.X < dbg.Columns.Count) and (gc.Y > 0) then
  begin
    SavedActiveRec := THackDbGrid(Dbg).DataLink.ActiveRecord;
    THackDbGrid(Dbg).DataLink.ActiveRecord := gc.Y - 1;
    Dbg.Hint := dbg.Columns[gc.X - 1].Field.AsString;
    THackDbGrid(Dbg).DataLink.ActiveRecord := SavedActiveRec;
  end
  else
    Dbg.Hint := '';
end;

Convert local TDateTime to GMT/UTC

Problem/Question/Abstract:

Does anybody know of any API or component that will convert a local datetime into GMT/UTC, using the Windows settings?

Answer:

Solve 1:

function NowUTC: TDateTime;
var
  system_datetime: TSystemTime;
begin
  GetSystemTime(system_datetime);
  Result := SystemTimeToDateTime(system_datetime);
end;


Solve 2:

{ ... }
const
  MinsPerDay = 24 * 60;

function GetGMTBias: Integer;
var
  info: TTimeZoneInformation;
  Mode: DWord;
begin
  Mode := GetTimeZoneInformation(info);
  Result := info.Bias;
  case Mode of
    TIME_ZONE_ID_INVALID:
      RaiseLastOSError;
    TIME_ZONE_ID_STANDARD:
      Result := Result + info.StandardBias;
    TIME_ZONE_ID_DAYLIGHT:
      Result := Result + info.DaylightBias;
  end;
end;

function GMTNow: TDateTime;
begin
  Result := LocaleToGMT(Now);
end;

function LocaleToGMT(const Value: TDateTime): TDateTime;
begin
  Result := Value + (GetGMTBias / MinsPerDay);
end;

function GMTToLocale(const Value: TDateTime): TDateTime;
begin
  Result := Value - (GetGMTBias / MinsPerDay);
end;


Solve 3:

function MakeUTCTime(DateTime: TDateTime): TDateTime;
var
  TZI: TTimeZoneInformation;
begin
  case GetTimeZoneInformation(TZI) of
    TIME_ZONE_ID_STANDARD:
      begin
        Result := DateTime + (TZI.Bias / 60 / 24);
      end;
    TIME_ZONE_ID_DAYLIGHT:
      begin
        Result := DateTime + (TZI.Bias / 60 / 24) + TZI.DaylightBias;
      end
  else
    raise
      Exception.Create('Error converting to UTC Time. Time zone could not be determined.');
  end;
end;

It's probably worth pointing out that this function will only work if the source of the TDateTime being converted was the system clock on the local machine (rather than, say, a field in a database or disk file) and if the timezone hasn't changed (e.g. between daylight saving and standard time) since the date was recorded.

Delphi Undocumented: Using BinToHex and HexToBin

Problem/Question/Abstract:

Undocumented BinToHex and HexToBin ?

Answer:

procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;

Many VCL and Windows API routines require TPoint or TRect records. To save declaring local variables and filling in the fields, you can use the set of routines declared in this unit. Point takes an X and Y co-ordinate, and produces a TPoint. Rect takes the left, top, right and bottom co-ordinates of a rectangle and manufactures a TRect record. Bounds is very similar to Rect but takes left, top, width and height information.

In Delphi 4 (and later), you will also find the undocumented BinToHex and HexToBin. These translate between binary data and a textual representation of it. They exist in all versions of Delphi, but Delphi 4 is the first to surface them outside the unit.

For example, an Extended variable is 10 bytes in size. Each byte is represented as two hexadecimal characters, so 20 characters are needed to display its contents in pure text. Listing 8 translates the 10 bytes of an Extended into a string (PChar) and then back again.

Using BinToHex and HexToBin

//Buffer is binary data,
//Text is target text buffer (assumed to be big enough),
//BufSize is size of binary data block
//procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);

//Text is textual representation of binary data,
//Buffer is target binary data buffer
//BufSize is size of textual data buffer
//function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;

procedure TForm1.Button1Click(Sender: TObject);
var
  E: Extended;
  //Make sure there is room for null terminator
  Buf: array[0..SizeOf(Extended) * 2] of Char;
begin
  E := Pi;
  Label1.Caption := Format('E starts off as %.15f', [E]);
  BinToHex(@E, Buf, SizeOf(E));
  //Slot in the null terminator for the PChar, so we can display it easily
  Buf[SizeOf(Buf) - 1] := #0;
  Label2.Caption := Format('As text, the binary contents of E look like %s', [Buf]);
  //Translate just the characters, not the null terminator
  HexToBin(Buf, @E, SizeOf(Buf) - 1);
  Label3.Caption := Format('Back from text to binary, E is now %.15f', [E]);
end;

Multi-tier Techniques

Problem/Question/Abstract:

Row-level Business Rules, Real Transaction Processing ,and More

Answer:

One problem many developers encountered while building multi-tier applications with Delphi 3 was implementing business rules in the middle-tier application server. You could create an OnUpdateData event handler for the TProvider component and validate all the records in the update (delta) packet sent to the application server by a call to ApplyUpdates in the client. However, using OnUpdateData required you to accept or reject all the records as a set. The only alternative was to use the TUpdateSQLProvider component, which Inprise made available with the Delphi 3.02 release. TUpdateSQLProvider wasn't an official part of the VCL, but it added an OnUpdateRecord event to the events provided by TProvider, giving you record-by-record control of the update process.

Delphi 4 has solved this problem in a very different way. In Delphi 4, the TProvider component has a new property -ResolveToDataSet. ResolveToDataSet is False by default, which provides the same behavior as Delphi 3. When ResolveToDataSet is True, updates are applied using the dataset component the provider is connected to. This causes all the dataset's events to fire as though the changes were being made manually or in code. Now, you can enforce business rules by blocking inserts, deletes, or posts with an exception, just as you would in a two-tier application.

The sample EbSrvr application that accompanies this article demonstrates this using the BeforePost event handler from the OrderTable object:

procedure TEbServer.OrderTableBeforePost(DataSet: TDataSet);
begin
  with DataSet do
    if FieldByName('ShipDate').AsDateTime <
      FieldByName('SaleDate').AsDateTime then
      raise Exception.Create(
        'Ship date must be greater than sale date.');
end;

This code raises an exception if the ShipDate is less than the SaleDate. In Delphi 3, raising an exception in the provider's OnUpdateData event handler caused an exception in the client application at the call to ApplyUpdates. However, raising an exception in one of the Before event handlers when ResolveToDataSet is True doesn't cause an exception in the client. Instead, the client's ReconcileError event is fired just as with any error generated by the VCL code in the server, or by the database server itself. This is a vast improvement because all errors, regardless of source, can be handled in the same way in the client.

The sample application uses the Reconcile Error dialog box from the Object Repository to handle all errors. If you try to post an order record whose ShipDate is less than the SaleDate, the error will appear in the Reconcile Error dialog box with the message text that you passed to the exception's constructor in the application server. The disadvantage of setting ResolveToDataSet to True is somewhat slower performance. [Note: EbSrvr and the other example projects discussed in this article are available for download; see end of article for details.]

Delphi 4 includes a new component -TDataSetProvider - that performs the same function as TProvider. However, it always applies updates to a dataset component in the middle-tier application. TDataSetProvider doesn't have the ability to apply updates directly to a database server by passing the dataset component. TDataSetProvider doesn't use the BDE, so it's the ideal choice if you're building a multi-tier application using a non-BDE database.

Controlling the Application Server

There are two ways for the client to control the application server in a multi-tier application: the first is by passing parameters to a query or stored procedure; the second is by executing custom methods on the server. Passing parameters to a TQuery, TStoredProc, or TTable in the application server was implemented in Delphi 3 using the Provider property of TClientDataSet to call the Provider's SetParams method passing as a parameter a variant array containing the parameters.

Delphi 4 provides a new way to do the same thing, as shown by code from the QClnt sample application (see Figure 1). This code is from the JobCodeCombo combo box's OnChange event handler.

procedure TMainForm.JobCodeComboChange(Sender: TObject);
begin
  with MainDm.EmployeeCds do
  begin
    { If the parameters have not been fetched from the server, fetch them. }
    if Params.Count = 0 then
      FetchParams;
    { Set the parameter values. }
    Params.ParamByName('Job_Code').AsString :=
      JobCodeCombo.Text;
    Params.ParamByName('Job_Grade').AsInteger :=
      StrToInt(JobGradeEdit.Text);
    { If the Employee client dataset isn't active, open it. Opening the dataset sends the parameters to the server. If it's already open, call SendParams to send the new parameter values to the server and refresh the dataset. }
    if not Active then
      Open
    else
    begin
      SendParams;
      Refresh;
    end; // if
  end; // with

  if not MainDm.SalaryCds.Active then
    MainDm.SalaryCds.Open;
end;
Figure 1: Setting parameters in the application server's query.

TClientDataSet now includes a Params property. You can fetch the parameters from the TQuery or TStoredProc component on the server at design time or run time. At design time, right-click the TClientDataSet and choose Fetch Params. At run time, call the FetchParams method.

The preceding code first checks the TClientDataSet.Params.Count property to see if any parameters have been fetched. If not, FetchParams is called. Once the parameter names and types have been fetched from the server, you can assign values to each parameter using the Params.ParamByName method.

You can send the parameters to the application server in one of two ways. If the TClientDataSet is closed, simply open it. Opening the ClientDataSet automatically sends the current parameter values to the application server. If the ClientDataSet is already open, call its SendParams method to send the new parameters to the application server. The server will automatically close the query or stored procedure, assign the new parameter values, then reopen the query. After calling SendParams, be sure to call the ClientDataSet's Refresh method so it will retrieve the new records from the application server.

Calling custom methods on the application server is no different than calling a custom method in any other automation server. The first step in implementing a custom method in the server that can be called from the client is to add the custom method to the server's interface using the Type Library Editor. Open the Type Library Editor by selecting Type Library from the View menu, then click on the interface to select it, as shown in Figure 2.


Figure 2: The Type Library Editor with the server's interface selected.

Click the New Method button to add as many methods as you need, and to add any parameters and a return value if required. Finally, click the Refresh Implementation button to update the type library interface unit, and add the new methods' stubs to the remote data module's unit. In the previous example, two new methods, FilterOn and FilterOff, were added to the interface. These methods can now be called from the client, using the connection component's AppServer property.

Early Binding

By default, the MIDAS connection components use late binding when calling methods of the application server. Although late binding works regardless of the type of connection between the client and the application server, it's slower than early binding. Also, early binding provides compile-time error checking of all your interface method calls. Early binding is only available if you use DCOM for the connection.

To use early binding, you must obtain an interface reference, which is simply a pointer to the interface's vtable (virtual method table), for the application server's interface. This is a two-step process. First, cast the connection component AppServer property to IUnknown or IDispatch to get an interface reference. This converts the AppServer property from a variant of variant type varDispatch to an interface reference. Next, cast the IUnknown or IDispatch interface to the interface type of the application server. This causes COM to call QueryInterface and return a reference to the application server's vtable. In the code in Figure 3, both casts are performed in a single statement. This code calls the custom FilterOn method that was added to the application server's interface using the Type Library Editor.

procedure TEcMainForm.ByName1Click(Sender: TObject);
var
  IServer: IEbServer;
begin
  with MainDm do
  begin
    IServer := IDispatch(EbConn.AppServer) as IEbServer;
    IServer.FilterOn;
    CustomerCds.Refresh;
  end;
end;
Figure 3: Calling a server method with early binding.

IEbServer is the application server's interface and IServer is an interface reference variable. EbConn is the TDCOMConnection component. To initialize the interface reference variable IServer to point to the interfaces virtual method table, the AppServer property is first cast to IDispatch, then to IEbServer. Once the interface variable has been initialized, it can be used to call the methods of the interface using early binding.

Although you cannot use early binding if you aren't using DCOM for the connection, you can improve performance compared to late binding by using the application server's dispatch interface. The code in Figure 4 is nearly identical to the previous example, except that the connection component's AppServer property is cast to the dispatch interface type, IEbServerDisp.

procedure TEcMainForm.ByCustomerNumber1Click(
  Sender: TObject);
var
  IDispServer: IEbServerDisp;
begin
  with MainDm do
  begin
    IDispServer :=
      IDispatch(EbConn.AppServer) as IEbServerDisp;
    IDispServer.FilterOff;
    CustomerCds.Refresh;
  end;
end;
Figure 4: Calling server methods using the dispatch interface.

Controlling the Client

The application server in a multi-tier application can call methods in the client application. This allows events that occur in the server to call event handlers in the client. The first step in allowing the server to call methods in the client is to add another interface to the server's type library, as shown in Figure 5.


Figure 5: Adding the IEbClient interface to the server.

This figure shows the type library for the sample EbSrvr application after adding a second interface, IEbClient. After adding the second interface, select it and add all the client methods that the server will call. In this case, a single method named ConfirmFilter was added to IEbClient. The client application will include an object that implements this interface.

Next, add a method to the server's interface, which takes a reference to the client interface as its only parameter. In Figure 5, this method is called ConnectClient. ConnectClient assigns its interface reference parameter to a variable that is added to the server's remote data module. The code in Figure 6 is the type declaration for the server's remote data module after the private member variable ClientConnection has been added.

type
  TEbServer = class(TRemoteDataModule, IEbServer)
    Database1: TDatabase;
    CustomerTable: TTable;
    CustomerProv: TProvider;
    OrderTable: TTable;
    OrderProv: TProvider;
    procedure EbServerCreate(Sender: TObject);
    procedure EbServerDestroy(Sender: TObject);
    procedure OrderTableBeforePost(DataSet: TDataSet);
    procedure CustomerProvGetDataSetProperties(
      Sender: TObject; DataSet: TDataSet;
      out Properties: OleVariant);
  private
    ClientConnection: IEbClient;
  protected
    function Get_CustomerProv: IProvider; safecall;
    function Get_OrderProv: IProvider; safecall;
    procedure FilterOn; safecall;
    procedure FilterOff; safecall;
    procedure ConnectClient(const Client: IEbClient);
      safecall;
    function IsDatabase: WordBool; safecall;
  end;
Figure 6: The server's remote data module with the ClientConnection added.

ClientConnection is the server's reference to the object that implements the IEbClient interface in the client. With this interface reference, the server can call any method of the interface. In this application, the code in Figure 7 is added to the server's FilterOn and FilterOff methods to confirm to the client that the filter on the Customer table is either on or off.

procedure TEbServer.FilterOn;
begin
  CustomerTable.Filtered := True;
  if CustomerTable.Filtered then
    ClientConnection.ConfirmFilter('Filter Is On')
  else
    ClientConnection.ConfirmFilter('Filter Is Off');
end;

procedure TEbServer.FilterOff;
begin
  CustomerTable.Filtered := False;
  if CustomerTable.Filtered then
    ClientConnection.ConfirmFilter('Filter Is On')
  else
    ClientConnection.ConfirmFilter('Filter Is Off');
end;
Figure 7: Callbacks to the client to confirm the filter state.

This code shows the use of the ClientConnection interface reference variable to call the ConfirmFilter method in the client application. On the client side, an object that implements the IEbClient interface must be added to the client application, as shown in the following:

TCallBack = class(TAutoIntfObject, IEbClient)
  procedure ConfirmFilter(const Msg: WideString); safecall;
end;

The TCallback object descends from TAutoInftObject, which provides support for the IDispatch interface. The implementation code for the ConfirmFilter method simply assigns the Msg parameter to the Caption property of a label on the client's main form so the user can see the message.

The heart of the callback mechanism is in the OnCreate event handler for the client application's main form (see Figure 8).

var
  ServerTypeLib: ITypeLib;
  TypeLibResult: HResult;
  CallBack: IEbClient;
  ...
    // Set up the callback interface.
  TypeLibResult := LoadRegTypeLib(LIBID_EbSrvr, 1, 0, 0,
    ServerTypeLib);
  if TypeLibResult <> S_OK then
  begin
    MessageDlg('Error loading type library.',
      mtError, [mbOK], 0);
    Exit;
  end; // if
  // Create an instance of the TCallback object.
  CallBack := TCallback.Create(ServerTypeLib, IEbClient);
  // Get an interface reference to the server.
  Srvr := IDispatch(MainDm.EbConn.AppServer) as IEbServer;
  // Pass the interface handle of the TCallback object to
// the server.
  Srvr.ConnectClient(CallBack);
  {...}
Figure 8: Creating the Callback object in the client main form's OnCreate event handler.

The variable declarations are global to the main form's unit. This code begins by calling the Windows API function LoadRegTypeLib to load the server's type library. The parameters are:

The type library's GUID.
The type library's major version number.
The type library's minor version number.
The national language code of the library.
An interface reference variable of type ITypeLib that is initialized by the call to point to the type library.

LoadRegTypeLib returns a result code indicating whether the type library was successfully loaded or not. If the library is successfully loaded, an instance of the TCallback automation object is created. The type library and interface that the TCallback object implements are passed as parameters to its constructor, and the returned value is assigned to the interface reference variable Callback. Next, a reference to the server's interface, IEbServer, is obtained by casting the connection component's AppServer property to the interface type. The final step is the statement:

Srvr.ConnectClient(CallBack);

which calls the server's ConnectClient method passing the interface reference variable for the TCallback object as a parameter. As you have seen, the server can now use this interface reference to call any method of the TCallback object that is a member of the IEbClient interface.

Controlling What the Client Sees

While letting the server call methods in the client is a very powerful way to implement a two-way exchange of information, there are other ways to control what the client sees. There are three ways to limit which fields the client application sees. The first is to use a query as the dataset in the application server and only select the fields the client application should see.

The second method is to create persistent field objects using the Fields Editor in the server application and only create field objects for those fields the client application should see. Note that if you create calculated or lookup fields in the Fields Editor, they will be sent to the client as read-only fields. There is a potential problem with limiting fields using the Fields Editor because you must include the entire primary key if the client will edit, delete, or insert records so that the record will be uniquely identified. If you need to include the primary key so the record can be edited, but do not want the client application to have access to one or more of the primary key fields, you can select the field object in the Fields Editor and use the Object Inspector to change the field object's ProviderFlags property to include the pfHidden flag. The effect is similar to rendering a field invisible in a grid by setting its Visible property to False. The field is there, but it cannot be accessed.

You can also add information to the data packets the server provides to the client. This can be any type of information, and you can specify that it also be included in the delta packets returned to the server when the client applies updates. This means the server can send a round-trip message to itself. The sample EbClnt and EbSrvr applications use this technique to send the current Filter property for the Customer table to the client for display.

To place additional information to the data packets sent by the provider component, begin by creating an event handler for the provider's OnGetDataSetProperties event. The event handler gets three parameters: the first is Sender, the second is DataSet, and the third is Properties. DataSet is a pointer to the dataset that supplies the provider's data. Properties is an OleVariant in which you place all the additional information you want included in the data packet. Properties must be a variant array, and must include three elements for each attribute you add to the data packet. The first element of the array is a string that contains the attribute's name. The second is a variant that contains its value, and the third is a Boolean value, which is True if you want the attribute returned in the delta packets.

To add more than one attribute to the data packet, make Properties a variant array of variant arrays, as shown in the code from the EbSrvr sample program in Figure 9.

procedure TEbServer.CustomerProvGetDataSetProperties(
  Sender: TObject; DataSet: TDataSet;
  out Properties: OleVariant);
begin
  Properties := VarArrayCreate([0, 1], varVariant);
  Properties[0] :=
    VarArrayOf(['Filter', DataSet.Filter, True]);
  Properties[1] :=
    VarArrayOf(['Filtered', DataSet.Filtered, False]);
end;
Figure 9: Adding information to the data packet.

This code adds two attributes to the data packet. The first contains the value of the dataset's Filter property, and the second the value of the dataset's Filtered property. Note that the Filter attribute is returned to the server in the delta packets. On the client side, use the TClientDataSet's GetOptionalParam method to retrieve the value of any attribute from the data packet. The following code is from the U.S. Only menu item's OnClick event handler:

FilterStringLabel.Caption := CustomerCds.GetOptionalParam('Filter');

This code retrieves the value of the Filter attribute as a variant, and assigns it to the FilterStringLabel's Caption property.

Real Transaction Control for Local Tables

Although Inprise claims there is transaction support for local Paradox and dBASE tables, it's not true. Transaction support requires the database always be left in a consistent state, i.e. either all or none of the changes that are part of a transaction will occur. For this to happen, the database must roll back all active transactions upon restart after a crash. Transactions for local tables are not rolled back after a crash; instead, any changes that were posted will still exist in the database even though the transaction was never committed.

There is a second major problem with local table transactions. The only transaction isolation level supported is tiDirtyRead, which can lead to serious problems. Suppose a physician is entering treatment information for a patient and accidentally enters drug therapy information for the wrong patient. If the record is posted, the change will now be visible to all other users even though the transaction is not committed. What happens if another user prints a list of drugs that must be administered at this point? Even though the physician reviews his/her entries and rolls back the transaction, the patient will still receive the wrong medication.

A much better solution when working with local tables is to use TClientDataSet for all data entry. This is easy to do in Delphi 4: Simply drop a TProvider and a TClientDataSet on a form or data module that already has a TTable connected to the table you want to edit. Set the DataSet property of the TProvider to the table, then set the Provider property of the TClientDataSet to the TProvider. This simple approach assumes that TClientDataSet can hold all the table's data in memory. If that's not the case, you will have to use ranges, filters, or queries to restrict the set of records the user works with at one time.

Why is TClientDataSet a better solution than local table transactions? First, consider what happens if one user changes a record, posts the change, then another user looks at the same record. The second user will see the unchanged version of the record until the first user calls the TClientDataSet's ApplyUpdates method to "commit" his or her transaction. This means that you effectively have read committed transaction isolation instead of dirty read transaction isolation.

Now consider what happens if a user makes several changes and his or her system crashes. Because both the data and changes made using a TClientDataSet are held in memory until ApplyUpdates is called, they will all be lost. This effectively gives you automatic rollback on restart after a crash. The only time you are vulnerable is during the brief interval between the moment you call ApplyUpdates and when the changes have actually been written to disk. If the workstation crashes while the writes are taking place, the database may be either inconsistent or corrupt; however, because the time that the database is in an inconsistent state is very short, the chances are small. By comparison, when you use local table transactions, the database is in an inconsistent state from the time the user posts the first change of the transaction until the user commits the transaction. This could be several minutes for a transaction that involves manually changing several records. The LclTran demonstration application shows an example of using TClientDataSet with local tables.

Using TClientDataSet for Flat-file Applications

TClientDataSet is a great tool for building single-user database applications that deal with modest amounts of data. It provides all the features of a relational database - except query support - with nothing to install or configure on the user's machine. All you have to do is distribute the dbclient.dll file with your program. The big limitation of TClientDataSet is that it holds all the data in memory. However, that is not as bad as it sounds when you consider that 100,000 records, 100 bytes in length, require 10MB of memory.

Using TClientDataSet for single-user, flat-file applications is much easier in Delphi 4. One of the most onerous aspects of writing a flat-file application in Delphi 3 is that the only way to create your data tables is in code. In Delphi 4, you can drop a TClientDataSet on a form or data module, and define your tables interactively using the Fields Editor. Simply double-click the TClientDataSet to open the Fields Editor and add new data fields. When you're done, right-click the TClientDataSet and choose Create DataSet from the context menu.

Another new feature useful in flat-file applications is the ability to use nested datasets. When you create a master TClientDataSet, you can add fields in the Fields Editor whose type is DataSet. To use the nested dataset, add another TClientDataSet to your project and set its DataSetField property to the field of type DataSet that you added to the master TClientDataSet. Now, open the Fields Editor for the detail TClientDataSet and add the fields for the detail dataset. Note that you don't have to add a foreign key field to link the detail to the master, because the detail is actually contained by the master.

One problem you may encounter is trying to add another field to a table after you have created the dataset. You can add the field in the Fields Editor, but you'll get an error when you right-click the TClientDataSet and choose Create Dataset. To overcome this, select the TClientDataSet and open the FieldDefs property in the Object Inspector by clicking its ellipsis button. In the Collection Editor, select all the field definitions and delete them. Now, right-click the TClientDataSet and choose Create DataSet to recreate all the field definitions, including the new field.

The sample Phone application demonstrates this technique. This is a simple, two-table application. The master contains people, and the detail contains phone numbers. One of the advantages of using nested datasets is that both the master and detail are saved in a single file, phone.ffd. The code from the Save Changes menu item's OnClick event handler first posts any unposted changes in both datasets, then merges the changes and saves the PersonCds to the phone.ffd file (see Figure 10). Note that only the Person dataset is saved, because it contains the numbers dataset.

procedure TMainForm.SaveChanges1Click(Sender: TObject);
begin
  { If there are unposted records post them. }
  if MainDm.PersonCds.State in [dsEdit, dsInsert] then
    MainDm.PersonCds.Post;
  if MainDm.NumberCds.State in [dsEdit, dsInsert] then
    MainDm.NumberCds.Post;
  { Merge the changes in Delta with the data and save it. }
  with MainDm.PersonCds do
  begin
    MergeChangeLog;
    SaveToFile('phone.ffd');
  end;
end;
Figure 10: Saving the master and detail tables in a single file.

There is, however, a big disadvantage to using nested datasets. You cannot search the entire detail dataset for a record. This would be a serious problem in a Customer/Orders relationship, where searching the entire Orders dataset by order number to find a specific order would be useful. Even in the sample Phone application, it might be nice to search for a person by phone number when you are trying to reconcile your long distance phone charges.

Maintained Aggregates

Maintained aggregates are another new feature of TClientDataSet in Delphi 4. They allow you to maintain the sum, count, min, max, or average of any number of fields in a TClientDataSet. What's even more valuable is that they support groups and expressions. You can use any index to group the aggregates. In the case of a composite index, you can also specify the number of fields to group on.

There are two ways to create and use maintained aggregates. The first is through the Aggregates property of TClientDataSet. Before creating any aggregates, be sure to set the AggregatesActive property of the TClientDataSet to True. You can set this property at any time - but don't forget it, or your aggregates won't work. Next, click the ellipsis button in the Aggregates property to open the Collection Editor. Then, press [Insert] to add an aggregate. Finally, set the aggregate's properties in the Object Inspector. Again, set the aggregate's Active property to True so you don't forget. Give the aggregate object a meaningful name, then enter an expression for the Expression property. The expression can use the Sum, Min, Max, Avg, or Count operators on a single field, or on an expression involving two or more fields. For example:

Sum(TaxRate * SaleAmount)

is a valid expression, as is:

Sum(Price) - Sum(Cost).

To group using an index, set the IndexName property to the index to use, and set the GroupingLevel property to the number of the last field in the index to group on. For example, if you have an index on the Country, Region, and SalesTerritory fields, set the GroupingLevel to 2 to group by Region. Setting the GroupingLevel to 0 disables grouping, so the aggregate will use all the records in the dataset. The sample Phone application uses an aggregate named TotalRecords to display the total number of records that have been saved.

To use the aggregate value, use the Aggregates property's Find method to get the value, as shown in Figure 11. The expression:

PersonCds.Aggregates.Find('TotalRecords').Value;

finds the named aggregate and calls its Value method to retrieve the current value of the aggregate.

procedure TMainForm.FormCreate(Sender: TObject);
begin
  TotalLabel.Caption :=
    IntToStr(MainDm.PersonCds.Aggregates.Find(
    'TotalRecords').Value) + ' saved records';
end;
Figure 11: Using the Aggregates.Find method.

Another alternative is to create an aggregate field using the Fields Editor. Add a new field to the TClientDataSet and choose Aggregate for the field type. Also, click the Aggregate radio button, then click OK to add the field. Select the field in the Fields Editor, then set the Name, Active, Expression, IndexName, and GroupingLevel properties. You can now access the aggregate like any other field in the dataset. This technique is particularly useful because it allows you to display the value of the aggregate using data aware controls without writing code.

Conclusion

Delphi 4 brings a host of new features for multi-tier application developers, but even more important are the new features of TClientDataSet that are available to all developers. Whether you're developing an enterprise multi-tier application, a traditional two-tier client/server system, or a file-server-based program, TClientDataSet offers you maintained aggregates, the briefcase model, better caching than cached updates, better local table transactions than the built-in local table transactions, nested-table, flat-file applications without the BDE, and more.

This is a whole new way to develop any application.


Component Download: http://www.baltsoft.com/files/dkb/attachment/Multi-tier_Techniques.zip

ZLIB Compressed Bitmaps

Problem/Question/Abstract:

Delphi provides native support for Windows Bitmaps and JPEG (since Delphi 3). While Windows Bitmaps are so big due to its old fashioned RLE compression schema, JPEG's are a small but lousy (you loose quality) option. Using ZLIB Bmp you still get the goods of the Bitmap format without the odds, and still save space and reduce the overall size of your Delphi executables noticeably.

Answer:

Introduction

In this article we will discuss (and implement) the use of powerful data compression algorithms and filters to store bitmap images on Delphi form files. The simplicity of the implementation will certainly shake you with surprise and I hope it will open the doors for other possibilities (data encryption, etc.). You'll find numerous techniques inside this article that will prove useful in many situations. There's a thing for everyone here (not only graphics people).

This article will develop around the following subjects:

ZLIB compression with Delphi (using T(De)CompressionStream)
Image filtering (same algorithms used in the PNG format)
Delphi streaming system and capabilities
Extending Delphi graphics capabilities (new file formats)
Advanced use of the TBitmap class


Overview

Delphi uses the TBitmap class to handle Windows Bitmap files (hereafter called bitmaps). This class encapsulates all the steps necessary to read a bitmap from a file or stream, display it onscreen, manipulate its contents, manage its palette, etc.

The TBitmap class, which inherits from TGraphic, overrides two inherited methods used for streaming to and from a form file: ReadData and WriteData. Every TGraphic descendant must provide its own implementation for these methods or an "Abstract Error" exception will be raised whenever Delphi tries to write or read the image data.

The TBitmap implementation of ReadData and WriteData calls the ReadStream and WriteStream private methods to do the actual reading and writing process respectively. These methods are also used by SaveToStream and LoadFromStream (public methods), so application developers can use them to read/write a bitmap file.

When called from within WriteData, the WriteStream method writes the size of the bitmap just before the data itself, so ReadData can retrieve this value and know how many bytes to read from the form file later. When called from SaveToStream, the WriteStream method writes the bitmap data to the stream with no additional information.

Windows bitmaps are at best RLE compressed, which is a very poor compression method. Your Delphi form files are going to get very big as more and more bitmaps are used in the design of your application interface. What we are going to do is to create a TBitmap derived class reimplementing the WriteData and ReadData methods so the data will be compressed when writting to the form file and decompressed when reading from it. This way you could still use bitmaps when creating the graphics for your forms not bothering to convert them to JPG (wich will loose quality, or GIF, whose support is not native to delphi, or other non-native format). Your bitmaps will be compressed before saved to the form file automaticly.

We'll use the ZLIB's deflate method for compression, since it offers very good compression rates at reasonable speed, its free and its already integrated with Delphi (ZLIB.PAS provides the TCompressionStream and TDecompressionStream classes we will be using here).

This new class will be called TZLIBBitmap, and its full implementation can be found later on this article.

To achieve better compression rates we'll use image filters. These filters are be the same filters used in the famous PNG file format, and will provide to our simple class compression rates comparable to those attained by this format.

We will also provide a method to save the data to any stream or file, so the application developer will have the option to write it to storage mediums other than the Delphi form file. We'll standardize the file extension for this format as ".ZBM" (Zlib compressed BitMap), and will register this file format within Delphi so you can use it at design time.

The stream created with this class can be easily identified and the class itself will be able to handle ordinary bitmap streams also.

ZLIB Compression

ZLIB is a free C library created by the folks who created the PNG file format. It implements the Deflate compression method which was popularized in the ZIP (PKWare products and many others). Borland made it easy for us to use the ZLIB library by creating the ZLIB.PAS unit, which links to the compiled OBJ files of the ZLIB Library. You'll find procedures to compress and decompress data, and also some specialized classes to do compression and decompression for you:

TCompressionStream: which compresses data to another stream while data is written to it
TDecompressionStream: which decompresses data from another stream when data is read from it

The use of these classes will be self-explaining in the code: we'll use TDecompressionStream in the ReadData method, and TCompressionStream in the WriteData method

Filtering

You should have noticed already that "zipping" a true-color bitmap isn't as good as converting it to PNG (or other compressed image format). This happens because you are using a compression program which isn't aware of what it is compressing. When we know what we're compressing, we can try to find better methods to compress the data. If changing the compression method isn't possible (which is our case because the ZLIB Bmp will use Deflate all the time) we should start to think in ways to change an otherwise low-compressive stream into a highly-compressive one. We can do that be means of filter algorithms which takes into account the nature of the data (Text files, for example, can be filtered taking into account that there is some repetitive aspects in every written language). Of course, the filter has to be reversible, or it will be impossible to extract the original data from the compressed stream!

In the case of images, we take into account that the pixels in pictures have surrounding pixels which are very near to each other in terms of color (Red, Green and Blue components). The compression of images is done on a row by row basis, and, if you didn't take into account the surrounding pixels we would not compress the image vertically (this happens to the GIF format!). That means that if you get an image 256 pixels wide and 256 pixels tall, and each collumn of pixels is one gray level above the previous with the first pixel being black (RGB=0), this picture  will not compress much if we didn't apply a filter to it. This picture in question is a very good example:

     pixels   0  1  2  3    ...   255
row 0        00 01 02 03 .. .. .. FF
row 1        00 01 02 03 .. .. .. FF
...
row 255      00 01 02 03 .. .. .. FF

The data of each row is the same, but each pixel in the row is different from the other. Compression algorithms use repetitive patterns of data to compress it, finding these patterns is the key to better compression (deflate is very good in that, while the old shrink method of pkzip is not as good). In the above example, there isn't any pattern in each row alone. Since the compression is done in each row independently it makes every row a very low-compressive (or even non-compressive) data stream.

But think a little! Every pixel in this example is exactly the previous plus one! If we stored only the difference beetween pixels (which is 1 in this example) we would create an ultra-highly-compressive stream. By applying the reverse of the algorithm we would be able to reconstruct the original data! Example:

Row 1 is made of the pixels 00 01 02 .. FF, storing the first pixel, and then storing the next by subtracting its value from the previous original value we will end up with a stream like: 00 01 01 01 .. 01, wich can be compressed to two or three bytes!!! The first byte is 0 (just store the first one), the second is 01 - 00 (previous) which gives 1. The fourth byte is 03 - 02 (third byte original value) which gives 1. Thats how we get to that filtered stream. To retrieve the original data we simply do the opposite: get the first byte (00), store it. Get the seconde filtered byte (01) and sum with the unfiltered previous (00) to get 01 (see the original stream data, it matches!), store it. Get the third compressed byte (01) and sum with the unfiltered previous (01) to get 02, store it... Get the tenth filtered byte (01) and the previous unfiltered one (08), sum them to get 09. Store it. Do that untill the 256th filtered byte (01) and sum with the unfiltered 255th (254) to get 255. Store it. Now you retrieved the original stream.

The filters used in this class are the same filters created by the creators of the PNG format (why in hell will you reinvent the wheel?). They work very well. There are four filter types: Sub, Up, Average, Paeth and None. Sub is the one we've been talking about before. Up is the same but stores the difference from the pixel with the pixel in the previous row (in our case it wouldn't make any difference). Average stores the arithmetic average of the sum of the pixel with its predecessor, and Paeth stores the average with the predecessor in the same row or the pixel just above or the previous from this pixel (up/left), whichever is near (in terms of colors). This filters are better explained in the png documentation. If you want to read it just point to the PNG home-page: http://www.libpng.org/pub/png/png.html and download it! By reading it and taking a look at the source here (in Pascal, which is better than C :-)

However there's a slight difference from the png filters and the ZBM filters. In the png file you can use a different filter for every row, in the ZBM, once a filter is selected it must be applied to all the rows in the image. This is mainly for simplicity, an the gain of addaptive filtering is not that big (but is noticeable!)

File Signature

When reading from a stream it is necessary to recognize right form the start if this is a valid ZLib stream. By means of a well chosen signature we can easily tell if a file is or not a ZLIB bitmap (without having to see it signature). In our case we have another use for it: since the ZLIB bmp will read the file from the form stream, and it will handle both ordinary bitmaps and ZBM bitmaps it is necessary to separate one from another. The signature test will do that: if we fail to read it we will read the stream as if it were a ordinary bitmap. That simple!

The signature choses is 6 bytes long and the rationales for the bytes are pretty much the same for the png signature (which I really liked).

The ZBM signature is: #213'ZMB'#13#10#26#10 (pascal string)

The character #213 was chosen to catch transmission errors from protocols which clears the 7th bit.
'ZBM' identifies the stream in a visual way.
The #13#10 is used to catch transmission errors from protocols who changes CRLF into CR or LF alone (unix/MAC text file style)
The #26 character tells MS-DOS to stop listing the file if you did a Type (DOS command) on it.
The last #10 character is used to catch transmission erros from protocols with expands individual LF's int CR/LF (MS-DOS text file style)

Streaming To Form Files (and etc.)

We will play with the LoadFromStream and SaveToStream, so we'll be able to read both windows bitmaps and ZLIB bitmaps from any file or stream. We will aso override the WriteData and ReadData method to be able to stream this highly-compressed data to a Delphi form file and to retrieve it accordingly later. If we didn't used filters this class would be that simple: only four overriden methods and we're done. But filtering is very very important. Without filter a 2.8 MB photo from Saturn will compress to 1.5MB. If we use a filter it will compress to 420 KB. This improvement is so big that I couldn't avoid the additional complexity added. The gains are worth the toll!!!

Additional Information

Many techniques used here (Scanline access, bitmap structure and information, etc.) aren't explained above. If you want more information you could read my other articles about these subjects:

Optimized Bitmap to Region (HRGN) Conversion - # 944
BitmapToRegion (Delphi-like version - very fast) (UPDATE: Bug fix!) - # 1009
Graying Bitmaps and Graphics - # 1465

I'm preparing an article about the TGraphic (something like TGraphic Unleashed!). And I plan to discuss every aspect of working with it and extending its functionallities (adding new file formats, creating effects, etc.). After that I will post a pascal PNG Implementation of my own and a TGA TGraphic descendant to show the use of TGraphic in Delphi. Stay tuned.

Using and Installing the ZLIB Bitmap

Just add this unit to one of your packages and add zLibBmp to the uses clause of the form you'll be using ZLib Bitmaps.

I didn't post any sample code here but I will upload a sample project soon. Just waits.

I hope you liked this article. See you soon.

Code starts here

unit zlibBmp;

{ ----------------------------------------------------------------------------
    TZLIBBitmap
    ---
    The TZLIBBitmap is a replacement for Delphi's TBitmap. It implements a
    powerful data compression schema using filters and zlib's deflate
    method to achieve compression rates as good as those attained by converting
    your bitmaps to PNG image format. Only data streamed down to the DFM
    file gets compressed (i.e.: SaveToStream/File saves an ordinary Windows
    Bitmap). That makes the use of ZLIBBitmap completely transparent to the
    application, to the developer and to Delphi IDE.

    TZLIBBitmap can read .BMP files since it is actually a TBitmap and can also
    handle ZLib Compressed Bitmaps (see SaveMethod bellow). The default
    extension for ZLib Compressed Bitmaps is .ZBM.

    TZLIBBitmap inherits from TBitmap all its properties and methods,
    introducing the following methods and properties:

    - SavingMode: TSavingMode
      - Tells which file format to use when streaming down the bitmap data to
      mediums other than the DFM file:
         . fmBitmap -> Unmodified bitmap data (Windows Bitmap)
         . fmZBM    -> ZLib Compressed Bitmap data. If saved to a file the .ZBM
                       extension should be used.
      When streaming to the Delphi form file the class writes a ZBM formatted
      stream regardless of the SavingMode property.
      Defaults to fmBitmap for full compatibility with TBitmap.

    SaveToStream (overriden)
      - Depends on the value of the SavingMode property. If it is fmZBM it
      writes a ZBM formatted stream (This is the actual compressed stream that
      is written to the DFM). This can later be read by LoadFromStream because
      the TZLIBBitmap.LoadFromStream can handle both Windows Bitmaps and ZLIB
      Compressed Bitmaps transparently. This option is provided for
      developers that need to store the ZBM stream in mediums other than the
      DFM file (database blobs, communication streams, etc.)
      If SavingMode is fmBitmap, it will call the inherited TBitmap.SaveToStream
      which will save an ordinary bitmap stream.

    LoadFromStream (overriden)
      - Loads a ZBM or Bitmap formatted stream. It first tries to recognize the
      stream as a ZBM stream calling ReadData if successfull, otherwise it calls
      the inherited LoadFromStream, which will try to load a bitmap stream.

    FilterMethod: TFilterMethod
      - This property tells which filter method to apply when writting the
      ZBM stream. The default method (fmPaeth) works better with the vast
      majority of images, so there's little if any reason to change this, but
      some images can compress better with other filters. It is up to the
      developer to choose which filter to apply or let the default.

    FUTURE OPTIMIZATIONS
    --------------------
    I don't need to compress the data again if it hasn't changed. I only need
    to hold the compressed data and then stream it down when needed. If the
    bitmap gets changed, I will need to recompress it. All I have to do is to
    create a memory stream with the compressed data, releasing it if the bitmap
    changes. When writting data, if the compressed data is available, I write it
    straight, otherwise I make the compression procedure again.

    License
    -------
    This code is freeware and its use in free or commercial products is granted.
    The code is provided as is and no warranty is supplied. USE IT AT YOUR OWN
    RISK. Although free this code is copyrighted 2000 by Felipe Machado, you
    can't claim authorship of it for any reason.
    If you use this component please send me an e-mail. I'll be glad to know
    your impressions, suggestions and critics (see contact below)

    Contact (Bug reports, etc.)
    ---------------------------
    Questions, bug reports, comments, they are all welcome. Please send then to

    felipe.machado@mail.com

    I will try to respond as soon as possible to every request. Thanks for the
    interest.

    ---
    (C) 2000, Felipe Rocha Machado
---------------------------------------------------------------------------- }

interface

uses
  SysUtils, Windows, Classes, Graphics, ZLIB;

type
  { redefined here so you won't be required to add ZLIB to the uses clause }
  TCompressionLevel = ZLIB.TCompressionLevel;

  { signature for ZBM file format }
  { #213 Z B M #13 #10 #26 #10 }
  TZBMSignature = array[0..7] of char;

  { filtering methods }
  TFilterMethod = (fmNone, fmPaeth, fmSub, fmUp, fmAverage);

  { Saving Mode - standard bitmap stream or ZLIB compressed stream }
  TSavingMode = (smBitmap, smZBM);

  { small header used to control encoding/decoding }
  TZBMHeader = packed record
    Signature: TZBMSignature;
    FilterMethod: TFilterMethod; // filter applied to the bitmap scanlines
    TotalSize: Cardinal; // uncompressed size
  end;

  { Defaults for every newly created ZLIB bitmap }
  TZBMDefaults = record
    SavingMode: TSavingMode;
    FilterMethod: TFilterMethod;
    CompressionLevel: TCompressionLevel; { clNone, clFastest, clDefault, clMax }
  end;

  { ZLIBBitmap class declaration }
  TZLIBBitmap = class(TBitmap)
  private
    FSavingMode: TSavingMode;
    function GetBpp: Byte;
  protected
    Header: TZBMHeader;
    procedure EncodeFilter(Dest: TBitmap);
    procedure DecodeFilter;
    procedure ReadData(Stream: TStream); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property FilterMethod: TFilterMethod read Header.FilterMethod
      write Header.FilterMethod;
    property SavingMode: TSavingMode read FSavingMode write FSavingMode;
  end;

var
  { Default behavior for ZLIB Bitmaps - mimics a class variable }
  ZBMDefaults: TZBMDefaults = (SavingMode: smBitmap;
    FilterMethod: fmPaeth;
    CompressionLevel: clMax); // this line was missing

implementation

type
  { array used to access memory by index }
  PHugeArray = ^THugeArray;
  THugeArray = array[0..MaxLongInt div SizeOf(Byte) div 8 - 1] of Byte;

const
  ZBMSignature: TZBMSignature = #213'ZBM'#13#10#26#10;

  { TZLIBBitmap }

constructor TZLIBBitmap.Create;
begin
  inherited Create;
  FilterMethod := ZBMDefaults.FilterMethod;
  FSavingMode := ZBMDefaults.SavingMode;
end;

procedure TZLIBBitmap.DecodeFilter;
var
  src, prev: PHugeArray;
  srcdif, size: Cardinal;
  bpp: Byte;
  zerobuffer: Pointer;
  { --- Local procedures for speed/readability --- }
  procedure DecNone; // should never be called since no change is done to scanlines
  begin
    // nothing to do - already decoded
  end;
  procedure DecPaeth;
  var
    x, y: Integer;
    a, b, c, pa, pb, pc, p: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      { first pixel is special case }
      for x := 0 to bpp - 1 do
        src[x] := (src[x] + prev[x]) and $FF;
      { now do paeth for every other byte }
      for x := bpp to size - 1 do
      begin
        a := src[x - bpp];
        b := prev[x];
        c := prev[x - bpp];
        p := b - c;
        pc := a - c;
        pa := Abs(p);
        pb := Abs(pc);
        pc := Abs(p + pc);
        if (pa <= pb) and (pa <= pc) then
          p := a
        else if (pb <= pc) then
          p := b
        else
          p := c;
        src[x] := (src[x] + p) and $FF;
      end;
      prev := src;
      Inc(Integer(src), srcdif);
    end;
  end;
  procedure DecSub;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      for x := bpp to size - 1 do
        src[x] := (src[x] + src[x - bpp]) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
    end;
  end;
  procedure DecUp;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      for x := 0 to size - 1 do
        src[x] := (src[x] + prev[x]) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
    end;
  end;
  procedure DecAverage;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      { first pixel is special case }
      for x := 0 to bpp - 1 do
        src[x] := (src[x] + prev[x] div 2) and $FF;
      for x := Bpp to size - 1 do
        src[x] := (src[x] + (src[x - bpp] + prev[x]) div 2) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
    end;
  end;

begin
  bpp := GetBpp;
  size := bpp * Width;
  if bpp = 1 then
    case PixelFormat of
      pf1bit: size := size div 8;
      pf4bit: size := size div 2;
    end;
  src := ScanLine[0];
  if Height > 1 then
    srcdif := Integer(ScanLine[1]) - Integer(src)
  else
    srcdif := 0;
  GetMem(zerobuffer, size);
  try
    FillChar(zerobuffer^, size, 0);
    prev := zerobuffer;
    case Header.FilterMethod of
      fmNone: DecNone;
      fmPaeth: DecPaeth;
      fmSub: DecSub;
      fmUp: DecUp;
      fmAverage: DecAverage;
    end;
  finally
    FreeMem(zerobuffer);
  end;
end;

procedure TZLIBBitmap.EncodeFilter(Dest: TBitmap);
var
  src, dst, prev: PHugeArray;
  srcdif, dstdif: Cardinal;
  size: Cardinal;
  bpp: Byte;
  zerobuffer: Pointer;
  //  a, b, c, pa, pb, pc: Byte;
    { local functions for speed and readability }
  procedure DoNone; // should never be called since no change is done to scanlines
  var
    y: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      Move(src^, dst^, size);
      prev := src;
      Inc(Integer(src), srcdif);
      Inc(Integer(dst), dstdif);
    end;
  end;
  procedure DoPaeth;
  var
    y, x: Integer;
    a, b, c, p, pa, pb, pc: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      { first pixel is special case }
      for x := 0 to bpp - 1 do
        dst[x] := (src[x] - prev[x]) and $FF;
      (* Paeth(x) = Raw(x) - PaethPredictor(Raw(x-bpp), Prior(x), Prior(x-bpp)) *)
      // a = left, b = above, c = upper left
      for x := bpp to size - 1 do
      begin
        a := src[x - bpp];
        b := prev[x];
        c := prev[x - bpp];
        p := a + b - c; // initial estimate
        pa := abs(p - a); // distances to a, b, c
        pb := abs(p - b);
        pc := abs(p - c);
        { return nearest of a,b,c,
          breaking ties in order a,b,c. }
        if (pa <= pb) and (pa <= pc) then
          p := a
        else if (pb <= pc) then
          p := b
        else
          p := c;
        dst[x] := (src[x] - p) and $FF;
      end;
      prev := src;
      Inc(Integer(src), srcdif);
      Inc(Integer(dst), dstdif);
    end;
  end;
  procedure DoSub;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      for x := bpp to size - 1 do
        dst[x] := (src[x] - src[x - bpp]) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
      Inc(Integer(dst), dstdif);
    end;
  end;
  procedure DoUp;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      for x := 0 to size - 1 do
        dst[x] := (src[x] - prev[x]) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
      Inc(Integer(dst), dstdif);
    end;
  end;
  procedure DoAverage;
  var
    y, x: Integer;
  begin
    for y := 0 to Height - 1 do
    begin
      { first pixel is special case }
      for x := 0 to bpp - 1 do
        dst[x] := (src[x] - prev[x] div 2) and $FF;
      for x := Bpp to size - 1 do
        dst[x] := (src[x] - (src[x - bpp] + prev[x]) div 2) and $FF;
      prev := src;
      Inc(Integer(src), srcdif);
      Inc(Integer(dst), dstdif);
    end;
  end;

begin
  bpp := GetBpp;
  size := bpp * Width;
  if bpp = 1 then
    case PixelFormat of
      pf1bit: size := size div 8;
      pf4bit: size := size div 2;
    end;
  src := ScanLine[0];
  dst := Dest.ScanLine[0];
  if Height > 1 then
  begin
    srcdif := Integer(ScanLine[1]) - Integer(src);
    dstdif := Integer(Dest.ScanLine[1]) - Integer(dst);
  end
  else
  begin
    srcdif := 0;
    dstdif := 0;
  end;
  GetMem(zerobuffer, size);
  try
    FillChar(zerobuffer^, size, 0);
    prev := zerobuffer;
    case Header.FilterMethod of
      fmNone: DoNone;
      fmPaeth: DoPaeth;
      fmSub: DoSub;
      fmUp: DoUp;
      fmAverage: DoAverage;
    end;
  finally
    FreeMem(zerobuffer);
  end;
end;

function TZLIBBitmap.GetBpp: Byte;
begin
  case PixelFormat of
    pf15bit,
      pf16bit: Result := 2;
    pf24bit: Result := 3;
    pf32bit: Result := 4;
  else
    Result := 1;
  end;
end;

procedure TZLIBBitmap.LoadFromStream(Stream: TStream);
var
  p: Integer;
begin
  p := Stream.Position;
  Stream.Read(Header, SizeOf(Header));
  Stream.Position := p;
  if Header.Signature <> ZBMSignature then // not a ZBM stream ...
    inherited LoadFromStream(Stream) // ... try reading a Bitmap stream
  else
    ReadData(Stream); // it's a ZBM stream. Read it.
  FilterMethod := ZBMDefaults.FilterMethod;
end;

procedure TZLIBBitmap.ReadData(Stream: TStream);
var
  DecStream: TDecompressionStream;
  tmpStream: TMemoryStream;
begin
  tmpStream := TMemoryStream.Create;
  try
    Stream.Read(Header, SizeOf(Header));
    if Header.Signature <> ZBMSignature then
      raise EInvalidGraphic.Create('Invalid ZBM signature!');
    DecStream := TDecompressionStream.Create(Stream);
    try
      tmpStream.CopyFrom(DecStream, Header.TotalSize);
    finally
      DecStream.Free;
    end;
    tmpStream.Position := 0;
    inherited LoadFromStream(tmpStream);
    if Header.FilterMethod <> fmNone then
      DecodeFilter;
  finally
    tmpStream.Free;
  end;
end;

procedure TZLIBBitmap.SaveToStream(Stream: TStream);
begin
  if SavingMode = smBitmap then
    inherited SaveToStream(Stream)
  else
    WriteData(Stream);
end;

procedure TZLIBBitmap.WriteData(Stream: TStream);
var
  CmpStream: TCompressionStream;
  tmpStream: TMemoryStream;
  bmp: TBitmap;
begin
  tmpStream := TMemoryStream.Create;
  try
    CmpStream := TCompressionStream.Create(ZBMDefaults.CompressionLevel, tmpStream);
    try
      if Header.FilterMethod = fmNone then
        inherited SaveToStream(CmpStream) // compresses unmodified bitmap
      else
      begin
        bmp := TBitmap.Create;
        try
          bmp.Assign(Self);
          EncodeFilter(bmp);
          bmp.SaveToStream(CmpStream); // compresses filtered bitmap
        finally
          bmp.Free;
        end;
      end;
      Header.TotalSize := CmpStream.Position;
    finally
      CmpStream.Free; // this will flush pending data to tmpStream
    end;
    tmpStream.Position := 0;
    Header.Signature := ZBMSignature;
    Stream.Write(Header, SizeOf(Header)); // writes ZBM header
    Stream.WriteBuffer(tmpStream.Memory^, tmpStream.Size);
  finally
    tmpStream.Free;
  end;
end;

initialization
  TPicture.UnregisterGraphicClass(TBitmap);
  TPicture.RegisterFileFormat('bmp', 'Windows Bitmaps (TZLIBBitmap)', TZLIBBitmap);
  TPicture.RegisterFileFormat('zbm', 'ZLIB Compressed Bitmap', TZLIBBitmap);
finalization
  TPicture.UnregisterGraphicClass(TZLIBBitmap);
  TPicture.RegisterFileFormat('bmp', 'Windows Bitmaps', TBitmap);
end.

How to save / load any TPicture-contained TGraphic to / from a stream

Problem/Question/Abstract:

How to save / load any TPicture-contained TGraphic to / from a stream

Answer:

I have a general solution for storing (and loading back) any TPicture-contained TGraphic's into and from a stream (no need to know which TGraphic descendant is contained in the TPicture):


TPictureFiler = class(TFiler)
public
  ReadData: TStreamProc;
  WriteData: TStreamProc;

  constructor Create; overload;

  procedure DefineProperty(const Name: string; ReadData: TReaderProc;
    WriteData: TWriterProc; HasData: Boolean); override;
  procedure DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc;
    HasData: Boolean); override;
  procedure FlushBuffer; override;
end;

{Since I use TFiler only partially, the inherited constructor TFiler.Create is unnecessary,
so I use this dummy}

constructor TPictureFiler.Create;
begin
end;

{Will be called by TPicture, handing over the private methods to read/write TPicture from/to Stream}

procedure TPictureFiler.DefineBinaryProperty(const Name: string; ReadData,
  WriteData: TStreamProc; HasData: Boolean);
begin
  if Name = 'Data' then
  begin
    Self.ReadData := ReadData;
    Self.WriteData := WriteData;
  end;
end;

procedure TPictureFiler.DefineProperty(const Name: string; ReadData: TReaderProc;
  WriteData: TWriterProc; HasData: Boolean);
begin
  {At this time TPicture don't call this function. Only implemented as a precaution
  to (unlikely) changes in future Delphi versions}
end;

procedure TPictureFiler.FlushBuffer;
begin
  {At this time TPicture don't call this function. Only implemented as precaution
  to (unlikely) changes in future Delphi versions}
end;

{Wrapper to call protected TPicture.DefineProperties. Must be in same unit
as ReadWritePictureFromStream}
type
  TMyPicture = class(TPicture)
  end;

procedure ReadWritePictureFromStream(Picture: TPicture; Stream: TStream; Read: Boolean);
var
  Filer: TPictureFiler;
begin
  Filer := TPictureFiler.Create;
  try
    {TPicture.DefineProperties is protected, but TMyPicture is declared in this unit.
    TMyPicture's protected members (also the inherited) are public to this unit}
    TMyPicture(Picture).DefineProperties(Filer);
    {TPicture.DefineProperties calls Filer.DefineBinaryProperty}
    if Read then
      Filer.ReadData(Stream) {TPicture does the work}
    else
      Filer.WriteData(Stream); {TPicture does the work}
  finally
    Filer.Free;
  end;
end;

{Whatever TIcons actual image size, its LoadFromStream(Stream: TStream) reads
just to the end of the stream. If I have additional things after TIcon streamed, they
are lost after TIcon.LoadFromStream. So I store the actual size before in the stream}

procedure WritePictureToStream(Picture: TPicture; Stream: TStream);
var
  MStream: TMemoryStream;
  iPictureSize: Integer;
begin
  MStream := TMemoryStream.Create;
  try
    ReadWritePictureFromStream(Picture, MStream, False);
    {Store TPicture data in TMemoryStream}
    iPictureSize := MStream.Size;
    Stream.WriteBuffer(iPictureSize, sizeof(iPictureSize));
    {Store size of TPicture data in TStream}
    Stream.WriteBuffer(MStream.Memory^, iPictureSize);
    {Store TMemoryStream(containing TPicture data) in TStream}
  finally
    MStream.Free;
  end;
end;

procedure ReadPictureFromStream(Picture: TPicture; Stream: TStream);
var
  MStream: TMemoryStream;
  iPictureSize: Integer;
begin
  MStream := TMemoryStream.Create;
  try
    Stream.ReadBuffer(iPictureSize, sizeof(iPictureSize));
    {Read size of TPicture data}
    MStream.SetSize(iPictureSize); {adjust buffer size}
    Stream.ReadBuffer(MStream.Memory^, iPictureSize); {get TPicture data}
    {Why TMemoryStream ? See what I said above about TIcon}
    ReadWritePictureFromStream(Picture, MStream, True); {read TPicture data}
  finally
    MStream.Free;
  end;
end;


Now WritePictureToStream and ReadPictureFromStream could be used to save/load any TPicture to / from any TStream. Example (in pseudo code):


TStream := TDataSet.CreateBlobStream(TBlobField, bmWrite);
try
  WritePictureToStream(TPicture, TStream);
finally
  TStream.Free;
end;

TStream := TDataSet.CreateBlobStream(TBlobField, bmRead);
try
  ReadPictureFromStream(TPicture, TStream);
finally
  TStream.Free;
end;


Perhaps this looks a bit tricky, but I think changes to the VCL and TPicture streaming system are
very unlikely.

Do you want TWAIN?

Problem/Question/Abstract:

Do you want TWAIN?

Answer:

////////////////////////////////////////////////////////////////////////
//                                                                    //
//               Delphi Scanner Support Framework                     //
//                                                                    //
//               Copyright (C) 1999 by Uli Tessel                     //
//                                                                    //
////////////////////////////////////////////////////////////////////////
//                                                                    //
//         Modified and rewritten as a Delphi component by:           //
//                                                                    //
//                           M. de Haan                               //
//                                                                    //
//                           June 2002                                //
//                                                                    //
////////////////////////////////////////////////////////////////////////

unit
  TWAIN;

interface

uses
  SysUtils, // Exceptions
  Forms, // TMessageEvent
  Windows, // HMODULE
  Graphics, // TBitmap
  IniFiles, // Inifile
  Controls, // TCursor
  Classes; // Class

const
  // Messages
  MSG_GET = $0001; // Get one or more values
  MSG_GETCURRENT = $0002; // Get current value
  MSG_GETDEFAULT = $0003; // Get default (e.g. power up) value
  MSG_GETFIRST = $0004; // Get first of a series of items,
  // e.g. Data Sources
  MSG_GETNEXT = $0005; // Iterate through a series of items
  MSG_SET = $0006; // Set one or more values
  MSG_RESET = $0007; // Set current value to default value
  MSG_QUERYSUPPORT = $0008; // Get supported operations on the
  // capacities

// Messages used with DAT_NULL
// ---------------------------
  MSG_XFERREADY = $0101; // The data source has data ready
  MSG_CLOSEDSREQ = $0102; // Request for the application to close
  // the Data Source
  MSG_CLOSEDSOK = $0103; // Tell the application to save the
  // state
  MSG_DEVICEEVENT = $0104; // Some event has taken place

  // Messages used with a pointer to a DAT_STATUS structure
  // ------------------------------------------------------
  MSG_CHECKSTATUS = $0201; // Get status information

  // Messages used with a pointer to DAT_PARENT data
  // -----------------------------------------------
  MSG_OPENDSM = $0301; // Open the Data Source Manager
  MSG_CLOSEDSM = $0302; // Close the Data Source Manager

  // Messages used with a pointer to a DAT_IDENTITY structure
  // --------------------------------------------------------
  MSG_OPENDS = $0401; // Open a Data Source
  MSG_CLOSEDS = $0402; // Close a Data Source
  MSG_USERSELECT = $0403; // Put up a dialog of all Data Sources
  // The user can select a Data Source

// Messages used with a pointer to a DAT_USERINTERFACE structure
// -------------------------------------------------------------
  MSG_DISABLEDS = $0501; // Disable data transfer in the Data
  // Source
  MSG_ENABLEDS = $0502; // Enable data transfer in the Data
  // Source
  MSG_ENABLEDSUIONLY = $0503; // Enable for saving Data Source state
  // only

// Messages used with a pointer to a DAT_EVENT structure
// -----------------------------------------------------
  MSG_PROCESSEVENT = $0601;

  // Messages used with a pointer to a DAT_PENDINGXFERS structure
  // ------------------------------------------------------------
  MSG_ENDXFER = $0701;
  MSG_STOPFEEDER = $0702;

  // Messages used with a pointer to a DAT_FILESYSTEM structure
  // ----------------------------------------------------------
  MSG_CHANGEDIRECTORY = $0801;
  MSG_CREATEDIRECTORY = $0802;
  MSG_DELETE = $0803;
  MSG_FORMATMEDIA = $0804;
  MSG_GETCLOSE = $0805;
  MSG_GETFIRSTFILE = $0806;
  MSG_GETINFO = $0807;
  MSG_GETNEXTFILE = $0808;
  MSG_RENAME = $0809;
  MSG_COPY = $080A;
  MSG_AUTOMATICCAPTUREDIRECTORY = $080B;

  // Messages used with a pointer to a DAT_PASSTHRU structure
  // --------------------------------------------------------
  MSG_PASSTHRU = $0901;

const
  DG_CONTROL = $0001; // data pertaining to control
  DG_IMAGE = $0002; // data pertaining to raster images

const
  // Data Argument Types for the DG_CONTROL Data Group.
  DAT_CAPABILITY = $0001; // TW_CAPABILITY
  DAT_EVENT = $0002; // TW_EVENT
  DAT_IDENTITY = $0003; // TW_IDENTITY
  DAT_PARENT = $0004; // TW_HANDLE,
  // application win handle in Windows
  DAT_PENDINGXFERS = $0005; // TW_PENDINGXFERS
  DAT_SETUPMEMXFER = $0006; // TW_SETUPMEMXFER
  DAT_SETUPFILEXFER = $0007; // TW_SETUPFILEXFER
  DAT_STATUS = $0008; // TW_STATUS
  DAT_USERINTERFACE = $0009; // TW_USERINTERFACE
  DAT_XFERGROUP = $000A; // TW_UINT32
  DAT_IMAGEMEMXFER = $0103; // TW_IMAGEMEMXFER
  DAT_IMAGENATIVEXFER = $0104; // TW_UINT32, loword is hDIB, PICHandle
  DAT_IMAGEFILEXFER = $0105; // Null data

const
  // Condition Codes: Application gets these by doing DG_CONTROL
  // DAT_STATUS MSG_GET.
  TWCC_CUSTOMBASE = $8000;
  TWCC_SUCCESS = 00; // It worked!
  TWCC_BUMMER = 01; // Failure due to unknown causes
  TWCC_LOWMEMORY = 02; // Not enough memory to perform operation
  TWCC_NODS = 03; // No Data Source
  TWCC_MAXCONNECTIONS = 04; // Data Source is connected to maximum
  // number of possible applications
  TWCC_OPERATIONERROR = 05; // Data Source or Data Source Manager
  // reported error, application
  // shouldn't report an error
  TWCC_BADCAP = 06; // Unknown capability
  TWCC_BADPROTOCOL = 09; // Unrecognized MSG DG DAT combination
  TWCC_BADVALUE = 10; // Data parameter out of range
  TWCC_SEQERROR = 11; // DG DAT MSG out of expected sequence
  TWCC_BADDEST = 12; // Unknown destination Application /
  // Source in DSM_Entry
  TWCC_CAPUNSUPPORTED = 13; // Capability not supported by source
  TWCC_CAPBADOPERATION = 14; // Operation not supported by
  // capability
  TWCC_CAPSEQERROR = 15; // Capability has dependancy on other
  // capability
  TWCC_DENIED = 16; // File System operation is denied
  // (file is protected)
  TWCC_FILEEXISTS = 17; // Operation failed because file
  // already exists
  TWCC_FILENOTFOUND = 18; // File not found
  TWCC_NOTEMPTY = 19; // Operation failed because directory
  // is not empty
  TWCC_PAPERJAM = 20; // The feeder is jammed
  TWCC_PAPERDOUBLEFEED = 21; // The feeder detected multiple pages
  TWCC_FILEWRITEERROR = 22; // Error writing the file (meant for
  // things like disk full conditions)
  TWCC_CHECKDEVICEONLINE = 23; // The device went offline prior to or
  // during this operation

const
  // Flags used in TW_MEMORY structure
  TWMF_APPOWNS = $01;
  TWMF_DSMOWNS = $02;
  TWMF_DSOWNS = $04;
  TWMF_POINTER = $08;
  TWMF_HANDLE = $10;

const
  // Flags for country, which seems to be equal to their telephone
  // number
  TWCY_AFGHANISTAN = 1001;
  TWCY_ALGERIA = 0213;
  TWCY_AMERICANSAMOA = 0684;
  TWCY_ANDORRA = 0033;
  TWCY_ANGOLA = 1002;
  TWCY_ANGUILLA = 8090;
  TWCY_ANTIGUA = 8091;
  TWCY_ARGENTINA = 0054;
  TWCY_ARUBA = 0297;
  TWCY_ASCENSIONI = 0247;
  TWCY_AUSTRALIA = 0061;
  TWCY_AUSTRIA = 0043;
  TWCY_BAHAMAS = 8092;
  TWCY_BAHRAIN = 0973;
  TWCY_BANGLADESH = 0880;
  TWCY_BARBADOS = 8093;
  TWCY_BELGIUM = 0032;
  TWCY_BELIZE = 0501;
  TWCY_BENIN = 0229;
  TWCY_BERMUDA = 8094;
  TWCY_BHUTAN = 1003;
  TWCY_BOLIVIA = 0591;
  TWCY_BOTSWANA = 0267;
  TWCY_BRITAIN = 0006;
  TWCY_BRITVIRGINIS = 8095;
  TWCY_BRAZIL = 0055;
  TWCY_BRUNEI = 0673;
  TWCY_BULGARIA = 0359;
  TWCY_BURKINAFASO = 1004;
  TWCY_BURMA = 1005;
  TWCY_BURUNDI = 1006;
  TWCY_CAMAROON = 0237;
  TWCY_CANADA = 0002;
  TWCY_CAPEVERDEIS = 0238;
  TWCY_CAYMANIS = 8096;
  TWCY_CENTRALAFREP = 1007;
  TWCY_CHAD = 1008;
  TWCY_CHILE = 0056;
  TWCY_CHINA = 0086;
  TWCY_CHRISTMASIS = 1009;
  TWCY_COCOSIS = 1009;
  TWCY_COLOMBIA = 0057;
  TWCY_COMOROS = 1010;
  TWCY_CONGO = 1011;
  TWCY_COOKIS = 1012;
  TWCY_COSTARICA = 0506;
  TWCY_CUBA = 0005;
  TWCY_CYPRUS = 0357;
  TWCY_CZECHOSLOVAKIA = 0042;
  TWCY_DENMARK = 0045;
  TWCY_DJIBOUTI = 1013;
  TWCY_DOMINICA = 8097;
  TWCY_DOMINCANREP = 8098;
  TWCY_EASTERIS = 1014;
  TWCY_ECUADOR = 0593;
  TWCY_EGYPT = 0020;
  TWCY_ELSALVADOR = 0503;
  TWCY_EQGUINEA = 1015;
  TWCY_ETHIOPIA = 0251;
  TWCY_FALKLANDIS = 1016;
  TWCY_FAEROEIS = 0298;
  TWCY_FIJIISLANDS = 0679;
  TWCY_FINLAND = 0358;
  TWCY_FRANCE = 0033;
  TWCY_FRANTILLES = 0596;
  TWCY_FRGUIANA = 0594;
  TWCY_FRPOLYNEISA = 0689;
  TWCY_FUTANAIS = 1043;
  TWCY_GABON = 0241;
  TWCY_GAMBIA = 0220;
  TWCY_GERMANY = 0049;
  TWCY_GHANA = 0233;
  TWCY_GIBRALTER = 0350;
  TWCY_GREECE = 0030;
  TWCY_GREENLAND = 0299;
  TWCY_GRENADA = 8099;
  TWCY_GRENEDINES = 8015;
  TWCY_GUADELOUPE = 0590;
  TWCY_GUAM = 0671;
  TWCY_GUANTANAMOBAY = 5399;
  TWCY_GUATEMALA = 0502;
  TWCY_GUINEA = 0224;
  TWCY_GUINEABISSAU = 1017;
  TWCY_GUYANA = 0592;
  TWCY_HAITI = 0509;
  TWCY_HONDURAS = 0504;
  TWCY_HONGKONG = 0852;
  TWCY_HUNGARY = 0036;
  TWCY_ICELAND = 0354;
  TWCY_INDIA = 0091;
  TWCY_INDONESIA = 0062;
  TWCY_IRAN = 0098;
  TWCY_IRAQ = 0964;
  TWCY_IRELAND = 0353;
  TWCY_ISRAEL = 0972;
  TWCY_ITALY = 0039;
  TWCY_IVORYCOAST = 0225;
  TWCY_JAMAICA = 8010;
  TWCY_JAPAN = 0081;
  TWCY_JORDAN = 0962;
  TWCY_KENYA = 0254;
  TWCY_KIRIBATI = 1018;
  TWCY_KOREA = 0082;
  TWCY_KUWAIT = 0965;
  TWCY_LAOS = 1019;
  TWCY_LEBANON = 1020;
  TWCY_LIBERIA = 0231;
  TWCY_LIBYA = 0218;
  TWCY_LIECHTENSTEIN = 0041;
  TWCY_LUXENBOURG = 0352;
  TWCY_MACAO = 0853;
  TWCY_MADAGASCAR = 1021;
  TWCY_MALAWI = 0265;
  TWCY_MALAYSIA = 0060;
  TWCY_MALDIVES = 0960;
  TWCY_MALI = 1022;
  TWCY_MALTA = 0356;
  TWCY_MARSHALLIS = 0692;
  TWCY_MAURITANIA = 1023;
  TWCY_MAURITIUS = 0230;
  TWCY_MEXICO = 0003;
  TWCY_MICRONESIA = 0691;
  TWCY_MIQUELON = 0508;
  TWCY_MONACO = 0033;
  TWCY_MONGOLIA = 1024;
  TWCY_MONTSERRAT = 8011;
  TWCY_MOROCCO = 0212;
  TWCY_MOZAMBIQUE = 1025;
  TWCY_NAMIBIA = 0264;
  TWCY_NAURU = 1026;
  TWCY_NEPAL = 0977;
  TWCY_NETHERLANDS = 0031;
  TWCY_NETHANTILLES = 0599;
  TWCY_NEVIS = 8012;
  TWCY_NEWCALEDONIA = 0687;
  TWCY_NEWZEALAND = 0064;
  TWCY_NICARAGUA = 0505;
  TWCY_NIGER = 0227;
  TWCY_NIGERIA = 0234;
  TWCY_NIUE = 1027;
  TWCY_NORFOLKI = 1028;
  TWCY_NORWAY = 0047;
  TWCY_OMAN = 0968;
  TWCY_PAKISTAN = 0092;
  TWCY_PALAU = 1029;
  TWCY_PANAMA = 0507;
  TWCY_PARAGUAY = 0595;
  TWCY_PERU = 0051;
  TWCY_PHILLIPPINES = 0063;
  TWCY_PITCAIRNIS = 1030;
  TWCY_PNEWGUINEA = 0675;
  TWCY_POLAND = 0048;
  TWCY_PORTUGAL = 0351;
  TWCY_QATAR = 0974;
  TWCY_REUNIONI = 1031;
  TWCY_ROMANIA = 0040;
  TWCY_RWANDA = 0250;
  TWCY_SAIPAN = 0670;
  TWCY_SANMARINO = 0039;
  TWCY_SAOTOME = 1033;
  TWCY_SAUDIARABIA = 0966;
  TWCY_SENEGAL = 0221;
  TWCY_SEYCHELLESIS = 1034;
  TWCY_SIERRALEONE = 1035;
  TWCY_SINGAPORE = 0065;
  TWCY_SOLOMONIS = 1036;
  TWCY_SOMALI = 1037;
  TWCY_SOUTHAFRICA = 0027;
  TWCY_SPAIN = 0034;
  TWCY_SRILANKA = 0094;
  TWCY_STHELENA = 1032;
  TWCY_STKITTS = 8013;
  TWCY_STLUCIA = 8014;
  TWCY_STPIERRE = 0508;
  TWCY_STVINCENT = 8015;
  TWCY_SUDAN = 1038;
  TWCY_SURINAME = 0597;
  TWCY_SWAZILAND = 0268;
  TWCY_SWEDEN = 0046;
  TWCY_SWITZERLAND = 0041;
  TWCY_SYRIA = 1039;
  TWCY_TAIWAN = 0886;
  TWCY_TANZANIA = 0255;
  TWCY_THAILAND = 0066;
  TWCY_TOBAGO = 8016;
  TWCY_TOGO = 0228;
  TWCY_TONGAIS = 0676;
  TWCY_TRINIDAD = 8016;
  TWCY_TUNISIA = 0216;
  TWCY_TURKEY = 0090;
  TWCY_TURKSCAICOS = 8017;
  TWCY_TUVALU = 1040;
  TWCY_UGANDA = 0256;
  TWCY_USSR = 0007;
  TWCY_UAEMIRATES = 0971;
  TWCY_UNITEDKINGDOM = 0044;
  TWCY_USA = 0001;
  TWCY_URUGUAY = 0598;
  TWCY_VANUATU = 1041;
  TWCY_VATICANCITY = 0039;
  TWCY_VENEZUELA = 0058;
  TWCY_WAKE = 1042;
  TWCY_WALLISIS = 1043;
  TWCY_WESTERNSAHARA = 1044;
  TWCY_WESTERNSAMOA = 1045;
  TWCY_YEMEN = 1046;
  TWCY_YUGOSLAVIA = 0038;
  TWCY_ZAIRE = 0243;
  TWCY_ZAMBIA = 0260;
  TWCY_ZIMBABWE = 0263;
  TWCY_ALBANIA = 0355;
  TWCY_ARMENIA = 0374;
  TWCY_AZERBAIJAN = 0994;
  TWCY_BELARUS = 0375;
  TWCY_BOSNIAHERZGO = 0387;
  TWCY_CAMBODIA = 0855;
  TWCY_CROATIA = 0385;
  TWCY_CZECHREPUBLIC = 0420;
  TWCY_DIEGOGARCIA = 0246;
  TWCY_ERITREA = 0291;
  TWCY_ESTONIA = 0372;
  TWCY_GEORGIA = 0995;
  TWCY_LATVIA = 0371;
  TWCY_LESOTHO = 0266;
  TWCY_LITHUANIA = 0370;
  TWCY_MACEDONIA = 0389;
  TWCY_MAYOTTEIS = 0269;
  TWCY_MOLDOVA = 0373;
  TWCY_MYANMAR = 0095;
  TWCY_NORTHKOREA = 0850;
  TWCY_PUERTORICO = 0787;
  TWCY_RUSSIA = 0007;
  TWCY_SERBIA = 0381;
  TWCY_SLOVAKIA = 0421;
  TWCY_SLOVENIA = 0386;
  TWCY_SOUTHKOREA = 0082;
  TWCY_UKRAINE = 0380;
  TWCY_USVIRGINIS = 0340;
  TWCY_VIETNAM = 0084;

const
  // Flags for languages
  TWLG_DAN = 000; // Danish
  TWLG_DUT = 001; // Dutch
  TWLG_ENG = 002; // English
  TWLG_FCF = 003; // French Canadian
  TWLG_FIN = 004; // Finnish
  TWLG_FRN = 005; // French
  TWLG_GER = 006; // German
  TWLG_ICE = 007; // Icelandic
  TWLG_ITN = 008; // Italian
  TWLG_NOR = 009; // Norwegian
  TWLG_POR = 010; // Portuguese
  TWLG_SPA = 011; // Spannish
  TWLG_SWE = 012; // Swedish
  TWLG_USA = 013;
  TWLG_AFRIKAANS = 014;
  TWLG_ALBANIA = 015;
  TWLG_ARABIC = 016;
  TWLG_ARABIC_ALGERIA = 017;
  TWLG_ARABIC_BAHRAIN = 018;
  TWLG_ARABIC_EGYPT = 019;
  TWLG_ARABIC_IRAQ = 020;
  TWLG_ARABIC_JORDAN = 021;
  TWLG_ARABIC_KUWAIT = 022;
  TWLG_ARABIC_LEBANON = 023;
  TWLG_ARABIC_LIBYA = 024;
  TWLG_ARABIC_MOROCCO = 025;
  TWLG_ARABIC_OMAN = 026;
  TWLG_ARABIC_QATAR = 027;
  TWLG_ARABIC_SAUDIARABIA = 028;
  TWLG_ARABIC_SYRIA = 029;
  TWLG_ARABIC_TUNISIA = 030;
  TWLG_ARABIC_UAE = 031; // United Arabic Emirates
  TWLG_ARABIC_YEMEN = 032;
  TWLG_BASQUE = 033;
  TWLG_BYELORUSSIAN = 034;
  TWLG_BULGARIAN = 035;
  TWLG_CATALAN = 036;
  TWLG_CHINESE = 037;
  TWLG_CHINESE_HONGKONG = 038;
  TWLG_CHINESE_PRC = 039; // People's Republic of China
  TWLG_CHINESE_SINGAPORE = 040;
  TWLG_CHINESE_SIMPLIFIED = 041;
  TWLG_CHINESE_TAIWAN = 042;
  TWLG_CHINESE_TRADITIONAL = 043;
  TWLG_CROATIA = 044;
  TWLG_CZECH = 045;
  TWLG_DANISH = TWLG_DAN;
  TWLG_DUTCH = TWLG_DUT;
  TWLG_DUTCH_BELGIAN = 046;
  TWLG_ENGLISH = TWLG_ENG;
  TWLG_ENGLISH_AUSTRALIAN = 047;
  TWLG_ENGLISH_CANADIAN = 048;
  TWLG_ENGLISH_IRELAND = 049;
  TWLG_ENGLISH_NEWZEALAND = 050;
  TWLG_ENGLISH_SOUTHAFRICA = 051;
  TWLG_ENGLISH_UK = 052;
  TWLG_ENGLISH_USA = TWLG_USA;
  TWLG_ESTONIAN = 053;
  TWLG_FAEROESE = 054;
  TWLG_FARSI = 055;
  TWLG_FINNISH = TWLG_FIN;
  TWLG_FRENCH = TWLG_FRN;
  TWLG_FRENCH_BELGIAN = 056;
  TWLG_FRENCH_CANADIAN = TWLG_FCF;
  TWLG_FRENCH_LUXEMBOURG = 057;
  TWLG_FRENCH_SWISS = 058;
  TWLG_GERMAN = TWLG_GER;
  TWLG_GERMAN_AUSTRIAN = 059;
  TWLG_GERMAN_LUXEMBOURG = 060;
  TWLG_GERMAN_LIECHTENSTEIN = 061;
  TWLG_GERMAN_SWISS = 062;
  TWLG_GREEK = 063;
  TWLG_HEBREW = 064;
  TWLG_HUNGARIAN = 065;
  TWLG_ICELANDIC = TWLG_ICE;
  TWLG_INDONESIAN = 066;
  TWLG_ITALIAN = TWLG_ITN;
  TWLG_ITALIAN_SWISS = 067;
  TWLG_JAPANESE = 068;
  TWLG_KOREAN = 069;
  TWLG_KOREAN_JOHAB = 070;
  TWLG_LATVIAN = 071;
  TWLG_LITHUANIAN = 072;
  TWLG_NORWEGIAN = TWLG_NOR;
  TWLG_NORWEGIAN_BOKMAL = 073;
  TWLG_NORWEGIAN_NYNORSK = 074;
  TWLG_POLISH = 075;
  TWLG_PORTUGUESE = TWLG_POR;
  TWLG_PORTUGUESE_BRAZIL = 076;
  TWLG_ROMANIAN = 077;
  TWLG_RUSSIAN = 078;
  TWLG_SERBIAN_LATIN = 079;
  TWLG_SLOVAK = 080;
  TWLG_SLOVENIAN = 081;
  TWLG_SPANISH = TWLG_SPA;
  TWLG_SPANISH_MEXICAN = 082;
  TWLG_SPANISH_MODERN = 083;
  TWLG_SWEDISH = TWLG_SWE;
  TWLG_THAI = 084;
  TWLG_TURKISH = 085;
  TWLG_UKRANIAN = 086;
  TWLG_ASSAMESE = 087;
  TWLG_BENGALI = 088;
  TWLG_BIHARI = 089;
  TWLG_BODO = 090;
  TWLG_DOGRI = 091;
  TWLG_GUJARATI = 092;
  TWLG_HARYANVI = 093;
  TWLG_HINDI = 094;
  TWLG_KANNADA = 095;
  TWLG_KASHMIRI = 096;
  TWLG_MALAYALAM = 097;
  TWLG_MARATHI = 098;
  TWLG_MARWARI = 099;
  TWLG_MEGHALAYAN = 100;
  TWLG_MIZO = 101;
  TWLG_NAGA = 102;
  TWLG_ORISSI = 103;
  TWLG_PUNJABI = 104;
  TWLG_PUSHTU = 105;
  TWLG_SERBIAN_CYRILLIC = 106;
  TWLG_SIKKIMI = 107;
  TWLG_SWEDISH_FINLAND = 108;
  TWLG_TAMIL = 109;
  TWLG_TELUGU = 110;
  TWLG_TRIPURI = 111;
  TWLG_URDU = 112;
  TWLG_VIETNAMESE = 113;

const
  TWRC_SUCCESS = 0;
  TWRC_FAILURE = 1; // Application may get TW_STATUS for
  // info on failure
  TWRC_CHECKSTATUS = 2; // tried hard to get the status
  TWRC_CANCEL = 3;
  TWRC_DSEVENT = 4;
  TWRC_NOTDSEVENT = 5;
  TWRC_XFERDONE = 6;
  TWRC_ENDOFLIST = 7; // After MSG_GETNEXT if nothing left
  TWRC_INFONOTSUPPORTED = 8;
  TWRC_DATANOTAVAILABLE = 9;

const
  TWON_ONEVALUE = $05; // indicates TW_ONEVALUE container
  TWON_DONTCARE8 = $FF;

const
  ICAP_XFERMECH = $0103;

const
  TWTY_UINT16 = $0004; // Means: item is a TW_UINT16

const
  // ICAP_XFERMECH values (SX_ means Setup XFer)
  TWSX_NATIVE = 0;
  TWSX_FILE = 1;
  TWSX_MEMORY = 2;
  TWSX_FILE2 = 3;

type
  TW_UINT16 = WORD; // unsigned short TW_UINT16
  pTW_UINT16 = ^TW_UINT16;
  TTWUInt16 = TW_UINT16;
  PTWUInt16 = pTW_UINT16;

type
  TW_BOOL = WORDBOOL; // unsigned short TW_BOOL
  pTW_BOOL = ^TW_BOOL;
  TTWBool = TW_BOOL;
  PTWBool = pTW_BOOL;

type
  TW_STR32 = array[0..33] of Char; // char TW_STR32[34]
  pTW_STR32 = ^TW_STR32;
  TTWStr32 = TW_STR32;
  PTWStr32 = pTW_STR32;

type
  TW_STR255 = array[0..255] of Char; // char TW_STR255[256]
  pTW_STR255 = ^TW_STR255;
  TTWStr255 = TW_STR255;
  PTWStr255 = pTW_STR255;

type
  TW_INT16 = SmallInt; // short TW_INT16
  pTW_INT16 = ^TW_INT16;
  TTWInt16 = TW_INT16;
  PTWInt16 = pTW_INT16;

type
  TW_UINT32 = ULONG; // unsigned long TW_UINT32
  pTW_UINT32 = ^TW_UINT32;
  TTWUInt32 = TW_UINT32;
  PTWUInt32 = pTW_UINT32;

type
  TW_HANDLE = THandle;
  TTWHandle = TW_HANDLE;
  TW_MEMREF = Pointer;
  TTWMemRef = TW_MEMREF;

type
  // DAT_PENDINGXFERS. Used with MSG_ENDXFER to indicate additional
  // data
  TW_PENDINGXFERS = packed record
    Count: TW_UINT16;
    case Boolean of
      False: (EOJ: TW_UINT32);
      True: (Reserved: TW_UINT32);
  end;
  pTW_PENDINGXFERS = ^TW_PENDINGXFERS;
  TTWPendingXFERS = TW_PENDINGXFERS;
  PTWPendingXFERS = pTW_PENDINGXFERS;

type
  // DAT_EVENT. For passing events down from the application to the DS
  TW_EVENT = packed record
    pEvent: TW_MEMREF; // Windows pMSG or Mac pEvent.
    TWMessage: TW_UINT16; // TW msg from data source, e.g.
    // MSG_XFERREADY
  end;
  pTW_EVENT = ^TW_EVENT;
  TTWEvent = TW_EVENT;
  PTWEvent = pTW_EVENT;

type
  // TWON_ONEVALUE. Container for one value
  TW_ONEVALUE = packed record
    ItemType: TW_UINT16;
    Item: TW_UINT32;
  end;
  pTW_ONEVALUE = ^TW_ONEVALUE;
  TTWOneValue = TW_ONEVALUE;
  PTWOneValue = pTW_ONEVALUE;

type
  // DAT_CAPABILITY. Used by application to get/set capability from/in
  // a data source.
  TW_CAPABILITY = packed record
    Cap: TW_UINT16; // id of capability to set or get, e.g.
    // CAP_BRIGHTNESS
    ConType: TW_UINT16; // TWON_ONEVALUE, _RANGE, _ENUMERATION or
    // _ARRAY
    hContainer: TW_HANDLE; // Handle to container of type Dat
  end;
  pTW_CAPABILITY = ^TW_CAPABILITY;
  TTWCapability = TW_CAPABILITY;
  PTWCapability = pTW_CAPABILITY;

type
  // DAT_STATUS. Application gets detailed status info from a data
  // source with this
  TW_STATUS = packed record
    ConditionCode: TW_UINT16; // Any TWCC_xxx constant
    Reserved: TW_UINT16; // Future expansion space
  end;
  pTW_STATUS = ^TW_STATUS;
  TTWStatus = TW_STATUS;
  PTWStatus = pTW_STATUS;

type
  // No DAT needed. Used to manage memory buffers
  TW_MEMORY = packed record
    Flags: TW_UINT32; // Any combination of the TWMF_ constants
    Length: TW_UINT32; // Number of bytes stored in buffer TheMem
    TheMem: TW_MEMREF; // Pointer or handle to the allocated memory
    // buffer
  end;
  pTW_MEMORY = ^TW_MEMORY;
  TTWMemory = TW_MEMORY;
  PTWMemory = pTW_MEMORY;

const
  // ICAP_IMAGEFILEFORMAT values (FF_means File Format
  TWFF_TIFF = 0; // Tagged Image File Format
  TWFF_PICT = 1; // Macintosh PICT
  TWFF_BMP = 2; // Windows Bitmap
  TWFF_XBM = 3; // X-Windows Bitmap
  TWFF_JFIF = 4; // JPEG File Interchange Format
  TWFF_FPX = 5; // Flash Pix
  TWFF_TIFFMULTI = 6; // Multi-page tiff file
  TWFF_PNG = 7; // Portable Network Graphic
  TWFF_SPIFF = 8;
  TWFF_EXIF = 9;

type
  // DAT_SETUPFILEXFER. Sets up DS to application data transfer via a
  // file
  TW_SETUPFILEXFER = packed record
    FileName: TW_STR255;
    Format: TW_UINT16; // Any TWFF_xxx constant
    VRefNum: TW_INT16; // Used for Mac only
  end;
  pTW_SETUPFILEXFER = ^TW_SETUPFILEXFER;
  TTWSetupFileXFER = TW_SETUPFILEXFER;
  PTWSetupFileXFER = pTW_SETUPFILEXFER;

type
  // DAT_SETUPFILEXFER2. Sets up DS to application data transfer via a
  // file. }
  TW_SETUPFILEXFER2 = packed record
    FileName: TW_MEMREF; // Pointer to file name text
    FileNameType: TW_UINT16; // TWTY_STR1024 or TWTY_UNI512
    Format: TW_UINT16; // Any TWFF_xxx constant
    VRefNum: TW_INT16; // Used for Mac only
    parID: TW_UINT32; // Used for Mac only
  end;
  pTW_SETUPFILEXFER2 = ^TW_SETUPFILEXFER2;
  TTWSetupFileXFER2 = TW_SETUPFILEXFER2;
  PTWSetupFileXFER2 = pTW_SETUPFILEXFER2;

type
  // DAT_SETUPMEMXFER. Sets up Data Source to application data
  // transfer via a memory buffer
  TW_SETUPMEMXFER = packed record
    MinBufSize: TW_UINT32;
    MaxBufSize: TW_UINT32;
    Preferred: TW_UINT32;
  end;
  pTW_SETUPMEMXFER = ^TW_SETUPMEMXFER;
  TTWSetupMemXFER = TW_SETUPMEMXFER;
  PTWSetupMemXFER = pTW_SETUPMEMXFER;

type
  TW_VERSION = packed record
    MajorNum: TW_UINT16; // Major revision number of the software.
    MinorNum: TW_UINT16; // Incremental revision number of the
    // software
    Language: TW_UINT16; // e.g. TWLG_SWISSFRENCH
    Country: TW_UINT16; // e.g. TWCY_SWITZERLAND
    Info: TW_STR32; // e.g. "1.0b3 Beta release"
  end;
  pTW_VERSION = ^TW_VERSION;
  PTWVersion = pTW_VERSION;
  TTWVersion = TW_VERSION;

type
  TW_IDENTITY = packed record
    Id: TW_UINT32; // Unique number. In Windows,
    // application hWnd
    Version: TW_VERSION; // Identifies the piece of code
    ProtocolMajor: TW_UINT16; // Application and DS must set to
    // TWON_PROTOCOLMAJOR
    ProtocolMinor: TW_UINT16; // Application and DS must set to
    // TWON_PROTOCOLMINOR
    SupportedGroups: TW_UINT32; // Bit field OR combination of DG_
    // constants
    Manufacturer: TW_STR32; // Manufacturer name, e.g.
    // "Hewlett-Packard"
    ProductFamily: TW_STR32; // Product family name, e.g.
    // "ScanJet"
    ProductName: TW_STR32; // Product name, e.g. "ScanJet Plus"
  end;
  pTW_IDENTITY = ^TW_IDENTITY;

type
  // DAT_USERINTERFACE. Coordinates UI between application and data
  // source
  TW_USERINTERFACE = packed record
    ShowUI: TW_BOOL; // TRUE if DS should bring up its UI
    ModalUI: TW_BOOL; // For Mac only - true if the DS's UI is modal
    hParent: TW_HANDLE; // For Windows only - Application handle
  end;
  pTW_USERINTERFACE = ^TW_USERINTERFACE;
  TTWUserInterface = TW_USERINTERFACE;
  PTWUserInterface = pTW_USERINTERFACE;

  ////////////////////////////////////////////////////////////////////////
  //                                                                    //
  //                END OF TWAIN TYPES AND CONSTANTS                    //
  //                                                                    //
  ////////////////////////////////////////////////////////////////////////

const
  TWAIN_DLL_Name = 'TWAIN_32.DLL';
  DSM_Entry_Name = 'DSM_Entry';
  Ini_File_Name = 'WIN.INI';
  CrLf = #13 + #10;

resourcestring // Errorstrings:
  ERR_DSM_ENTRY_NOT_FOUND = 'Unable to find the entry of the Data ' +
    'Source Manager in: TWAIN_32.DLL';
  ERR_TWAIN_NOT_LOADED = 'Unable to load or find: TWAIN_32.DLL';
  ERR_DSM_CALL_FAILED = 'A call to the Data Source Manager failed ' +
    'in module %s';
  ERR_UNKNOWN = 'A call to the Data Source Manager failed ' +
    'in module %s: Code %.04x';
  ERR_DSM_OPEN = 'Unable to close the Data Source Manager. ' +
    'Maybe a source is still in use';
  ERR_STATUS = 'Unable to get the status';
  ERR_DSM = 'Data Source Manager error in module %s:' +
    CrLf + '%s';
  ERR_DS = 'Data Source error in module %s:' +
    CrLf + '%s';

type
  ETwainError = class(Exception);
  TImageType = (ffTIFF, ffPICT, ffBMP, ffXBM, ffJFIF, ffFPX,
    ffTIFFMULTI, ffPNG, ffSPIFF, ffEXIF, ffUNKNOWN);
  TTransferType = (xfNative, xfMemory, xfFile);
  TLanguageType = (lgDutch, lgEnglish,
    lgFrench, lgGerman,
    lgAmerican, lgItalian,
    lgSpanish, lgNorwegian,
    lgFinnish, lgDanish,
    lgRussian, lgPortuguese,
    lgSwedish, lgPolish,
    lgGreek, lgTurkish);
  TCountryType = (ctNetherlands, ctEngland,
    ctFrance, ctGermany,
    ctUSA, ctSpain,
    ctItaly, ctDenmark,
    ctFinland, ctNorway,
    ctRussia, ctPortugal,
    ctSweden, ctPoland,
    ctGreece, ctTurkey);
  TTWAIN = class(TComponent)
  private
    // Private declarations
    fBitmap: TBitmap; // the actual bmp used for
    // scanning, must be
    // removed
    HDSMDLL: HMODULE; // = 0, the library handle:
    // will stay global
    appId: TW_IDENTITY; // our (Application) ID.
    // (may stay global)
    dsId: TW_IDENTITY; // Data Source ID (will
    // become member of DS
    // class)
    fhWnd: HWND; // = 0, maybe will be
    // removed, use
    // application.handle
    // instead
    fXfer: TTransferType; // = xfNative;
    bDataSourceManagerOpen: Boolean; // = False, flag, may stay
    // global
    bDataSourceOpen: Boolean; // = False, will become
    // member of DS class
    bDataSourceEnabled: Boolean; // = False, will become
    // member of DS class
    fScanReady: TNotifyEvent; // notifies that the scan
    // is ready
    sDefaultSource: string; // remember old data source
    fOldOnMessageHandler: TMessageEvent; // Save old OnMessage event
    fShowUI: Boolean; // Show User Interface
    fSetupFileXfer: TW_SETUPFILEXFER; // Not used yet
    fSetupMemoryXfer: TW_SETUPMEMXFER; // Not used yet
    fMemory: TW_MEMORY; // Not used yet

    function fLoadTwain: Boolean;
    procedure fUnloadTwain;
    function fNativeXfer: Boolean;
    function fMemoryXfer: Boolean; // Not used yet
    function fFileXfer: Boolean; // Not used yet
    function fGetDestination: TTransferType;
    procedure fSetDestination(dest: TTransferType);
    function Condition2String(ConditionCode: TW_UINT16): string;
    procedure RaiseLastDataSourceManagerCondition(module: string);
    procedure RaiseLastDataSourceCondition(module: string);
    procedure TwainCheckDataSourceManager(res: TW_UINT16;
      module: string);
    procedure TwainCheckDataSource(res: TW_UINT16;
      module: string);

    function CallDataSourceManager(pOrigin: pTW_IDENTITY;
      DG: TW_UINT32;
      DAT: TW_UINT16;
      MSG: TW_UINT16;
      pData: TW_MEMREF): TW_UINT16;

    function CallDataSource(DG: TW_UINT32;
      DAT: TW_UINT16;
      MSG: TW_UINT16;
      pData: TW_MEMREF): TW_UINT16;

    procedure XferMech;
    procedure fSetProductname(pn: string);
    function fGetProductname: string;
    procedure fSetManufacturer(mf: string);
    function fGetManufacturer: string;
    procedure fSetProductFamily(pf: string);
    function fGetProductFamily: string;
    procedure fSetLanguage(lg: TLanguageType);
    function fGetLanguage: TLanguageType;
    procedure fSetCountry(ct: TCountryType);
    function fGetCountry: TCountryType;
    procedure SaveDefaultSourceEntry;
    procedure RestoreDefaultSourceEntry;
    procedure fSetCursor(cr: TCursor);
    function fGetCursor: TCursor;
    procedure fSetImageType(it: TImageType);
    function fGetImageType: TImageType;
    procedure fSetFilename(fn: string);
    function fGetFilename: string;
    procedure fSetVersionInfo(vi: string);
    function fGetVersionInfo: string;
    procedure fSetVersionMajor(vmaj: WORD);
    procedure fSetVersionMinor(vmin: WORD);
    function fGetVersionMajor: WORD;
    function fGetVersionMinor: WORD;

  protected
    procedure ScanReady; dynamic; // Notifies when image transfer is
    // ready
    procedure fNewOnMessageHandler(var Msg: TMsg;
      var Handled: Boolean); virtual;

  public
    // Public declarations
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Acquire(aBmp: TBitmap);
    procedure OpenDataSource;
    procedure CloseDataSource;
    procedure InitTWAIN;
    procedure OpenDataSourceManager;
    procedure CloseDataSourceManager;
    function IsDataSourceManagerOpen: Boolean;
    procedure EnableDataSource;
    // Procedure TWEnableDSUIOnly(ShowUI : Boolean);
    procedure DisableDataSource;
    function IsDataSourceOpen: Boolean;
    function IsDataSourceEnabled: Boolean;
    procedure SelectDataSource;
    function IsTwainDriverAvailable: Boolean;
    function ProcessSourceMessage(var Msg: TMsg): Boolean;

  published
    // Published declarations
    // Properties, methods
    property Destination: TTransferType
      read fGetDestination write fSetDestination;
    property TwainDriverFound: Boolean
      read IsTwainDriverAvailable;
    property Productname: string
      read fGetProductname write fSetProductname;
    property Manufacturer: string
      read fGetManufacturer write fSetManufacturer;
    property ProductFamily: string
      read fGetProductFamily write fSetProductFamily;
    property Language: TLanguageType
      read fGetLanguage write fSetLanguage;
    property Country: TCountryType
      read fGetCountry write fSetCountry;
    property ShowUI: Boolean
      read fShowUI write fShowUI;
    property Cursor: TCursor
      read fGetCursor write fSetCursor;
    property FileFormat: TImageType
      read fGetImageType write fSetImageType;
    property Filename: string
      read fGetFilename write fSetFilename;
    property VersionInfo: string
      read fGetVersionInfo write fSetVersionInfo;
    property VersionMajor: WORD
      read fGetVersionMajor write fSetVersionMajor;
    property VersionMinor: WORD
      read fGetVersionMinor write fSetVersionMinor;
    // Events
    property OnScanReady: TNotifyEvent
      read fScanReady write fScanReady;
  end;

procedure Register;

type
  DSMENTRYPROC = function(pOrigin: pTW_IDENTITY;
    pDest: pTW_IDENTITY;
    DG: TW_UINT32;
    DAT: TW_UINT16;
    MSG: TW_UINT16;
    pData: TW_MEMREF): TW_UINT16; stdcall;
  TDSMEntryProc = DSMENTRYPROC;

type
  DSENTRYPROC = function(pOrigin: pTW_IDENTITY;
    DG: TW_UINT32;
    DAT: TW_UINT16;
    MSG: TW_UINT16;
    pData: TW_MEMREF): TW_UINT16; stdcall;
  TDSEntryProc = DSENTRYPROC;

var
  DS_Entry: TDSEntryProc = nil; // Initialize
  DSM_Entry: TDSMEntryProc = nil; // Initialize

implementation

//---------------------------------------------------------------------

constructor TTWAIN.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  // Initialize variables
  appID.Version.Info := 'Twain component';
  appID.Version.Country := TWCY_USA;
  appID.Version.Language := TWLG_USA;
  appID.Productname := 'SimpelSoft TWAIN module'; // This is the one that you are
  // going to see in the UI
  appID.ManuFacturer := 'SimpelSoft';
  appID.ProductFamily := 'SimpelSoft components';
  appID.Version.MajorNum := 1;
  appID.Version.MinorNum := 0;
  // appID.ID := Application.Handle;

  fSetFilename('C:\TWAIN.BMP');
  // fSetupFileXfer.FileName := 'C:\TWAIN.TMP':
  fSetImageType(ffBMP);
  // fSetupFileXfer.Format := TWFF_BMP;
  // fSetupFileXfer.VRefNum := xx; // For Mac
  // fSetupMemoryXfer.MinBufSize := xx;
  // fSetupMemoryXfer.MaxBufSize := yy;
  // fSetupMemoryXfer.Preferred := zz;
  fMemory.Flags := TWFF_BMP;
  // fMemory.Length := SizeOf(Mem);
  // fMemory.TheMem := @Mem;

  // fhWnd := Application.Handle;
  fShowUI := True;

  HDSMDLL := 0;
  sDefaultSource := '';
  fXfer := xfNative;
  bDataSourceManagerOpen := False;
  bDataSourceOpen := False;
  bDataSourceEnabled := False;
end;
//---------------------------------------------------------------------

destructor TTWAIN.Destroy;

begin
  if bDataSourceEnabled then
    DisableDataSource;
  if bDataSourceOpen then
    CloseDataSource;
  if bDataSourceManagerOpen then
    CloseDataSourceManager;
  fUnLoadTwain; // Loose the TWAIN_32.DLL
  if sDefaultSource <> '' then
    RestoreDefaultSourceEntry; // Write old entry back in WIN.INI
  Application.OnMessage := fOldOnMessageHandler; // Restore old OnMessage
  // handler
  inherited Destroy;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionMajor: WORD;

begin
  Result := appID.Version.MajorNum;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionMinor: WORD;

begin
  Result := appID.Version.MinorNum;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionMajor(vmaj: WORD);

begin
  appID.Version.MajorNum := vmaj;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionMinor(vmin: WORD);

begin
  appID.Version.MinorNum := vmin;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionInfo(vi: string);

var
  I, L: Integer;

begin
  FillChar(appID.Version.Info, SizeOf(appID.Version.Info), #0);
  L := Length(vi);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Version.Info[I - 1] := vi[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionInfo: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.Version.Info[I] <> #0 then
    repeat
      Result := Result + appID.Version.Info[I];
      Inc(I);
    until appID.Version.Info[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetImageType(it: TImageType);

begin
  fSetupFileXfer.Format := TWFF_BMP; // Initialize
  fMemory.Flags := TWFF_BMP; // Initialize

  case it of
    ffTIFF:
      begin
        fSetupFileXfer.Format := TWFF_TIFF;
        fMemory.Flags := TWFF_TIFF;
      end;
    ffPICT:
      begin
        fSetupFileXfer.Format := TWFF_PICT;
        fMemory.Flags := TWFF_PICT;
      end;
    ffBMP:
      begin
        fSetupFileXfer.Format := TWFF_BMP;
        fMemory.Flags := TWFF_BMP;
      end;
    ffXBM:
      begin
        fSetupFileXfer.Format := TWFF_XBM;
        fMemory.Flags := TWFF_XBM;
      end;
    ffJFIF:
      begin
        fSetupFileXfer.Format := TWFF_JFIF;
        fMemory.Flags := TWFF_JFIF;
      end;
    ffFPX:
      begin
        fSetupFileXfer.Format := TWFF_FPX;
        fMemory.Flags := TWFF_FPX;
      end;
    ffTIFFMULTI:
      begin
        fSetupFileXfer.Format := TWFF_TIFFMULTI;
        fMemory.Flags := TWFF_TIFFMULTI;
      end;
    ffPNG:
      begin
        fSetupFileXfer.Format := TWFF_PNG;
        fMemory.Flags := TWFF_PNG;
      end;
    ffSPIFF:
      begin
        fSetupFileXfer.Format := TWFF_SPIFF;
        fMemory.Flags := TWFF_SPIFF;
      end;
    ffEXIF:
      begin
        fSetupFileXfer.Format := TWFF_EXIF;
        fMemory.Flags := TWFF_EXIF;
      end;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetFilename(fn: string);

var
  L, I: Integer;

begin
  FillChar(fSetupFileXfer.FileName, SizeOf(fSetupFileXfer.Filename), #0);
  L := Length(fn);
  if L > 0 then
    for I := 1 to L do
      fSetupFileXfer.Filename[I - 1] := fn[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetFilename: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if fSetupFileXfer.Filename[I] <> #0 then
    repeat
      Result := Result + fSetupFileXfer.Filename[I];
      Inc(I);
    until fSetupFileXfer.Filename[I] = #0;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetImageType: TImageType;

begin
  Result := ffUNKNOWN; // Initialize
  case fSetupFileXfer.Format of
    TWFF_TIFF: Result := ffTIFF;
    TWFF_PICT: Result := ffPICT;
    TWFF_BMP: Result := ffBMP;
    TWFF_XBM: Result := ffXBM;
    TWFF_JFIF: Result := ffJFIF;
    TWFF_FPX: Result := ffFPX;
    TWFF_TIFFMULTI: Result := ffTIFFMULTI;
    TWFF_PNG: Result := ffPNG;
    TWFF_SPIFF: Result := ffSPIFF;
    TWFF_EXIF: Result := ffEXIF;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetCursor(cr: TCursor);

begin
  Screen.Cursor := cr;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetCursor: TCursor;

begin
  Result := Screen.Cursor;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetCountry(ct: TCountryType);

begin
  case ct of
    ctDenmark: appID.Version.Country := TWCY_DENMARK;
    ctNetherlands: appID.Version.Country := TWCY_NETHERLANDS;
    ctEngland: appID.Version.Country := TWCY_BRITAIN;
    ctFinland: appID.Version.Country := TWCY_FINLAND;
    ctFrance: appID.Version.Country := TWCY_FRANCE;
    ctGermany: appID.Version.Country := TWCY_GERMANY;
    ctItaly: appID.Version.Country := TWCY_ITALY;
    ctNorWay: appID.Version.Country := TWCY_NORWAY;
    ctSpain: appID.Version.Country := TWCY_SPAIN;
    ctUSA: appID.Version.Country := TWCY_USA;
    ctRussia: appID.Version.Country := TWCY_RUSSIA;
    ctPortugal: appID.Version.Country := TWCY_PORTUGAL;
    ctSweden: appID.Version.Country := TWCY_SWEDEN;
    ctPoland: appID.Version.Country := TWCY_POLAND;
    ctGreece: appID.Version.Country := TWCY_GREECE;
    ctTurkey: appID.Version.Country := TWCY_TURKEY;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetCountry: TCountryType;

begin
  Result := ctNetherlands; // Initialize
  case appID.Version.Country of
    TWCY_NETHERLANDS: Result := ctNetherlands;
    TWCY_DENMARK: Result := ctDenmark;
    TWCY_BRITAIN: Result := ctEngland;
    TWCY_FINLAND: Result := ctFinland;
    TWCY_FRANCE: Result := ctFrance;
    TWCY_GERMANY: Result := ctGermany;
    TWCY_NORWAY: Result := ctNorway;
    TWCY_ITALY: Result := ctItaly;
    TWCY_SPAIN: Result := ctSpain;
    TWCY_USA: Result := ctUSA;
    TWCY_RUSSIA: Result := ctRussia;
    TWCY_PORTUGAL: Result := ctPortugal;
    TWCY_SWEDEN: Result := ctSweden;
    TWCY_TURKEY: Result := ctTurkey;
    TWCY_GREECE: Result := ctGreece;
    TWCY_POLAND: Result := ctPoland;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetLanguage(lg: TLanguageType);

begin
  case lg of
    lgDanish: appID.Version.Language := TWLG_DAN;
    lgDutch: appID.Version.Language := TWLG_DUT;
    lgEnglish: appID.Version.Language := TWLG_ENG;
    lgFinnish: appID.Version.Language := TWLG_FIN;
    lgFrench: appID.Version.Language := TWLG_FRN;
    lgGerman: appID.Version.Language := TWLG_GER;
    lgNorwegian: appID.Version.Language := TWLG_NOR;
    lgItalian: appID.Version.Language := TWLG_ITN;
    lgSpanish: appID.Version.Language := TWLG_SPA;
    lgAmerican: appID.Version.Language := TWLG_USA;
    lgRussian: appID.Version.Language := TWLG_RUSSIAN;
    lgPortuguese: appID.Version.Language := TWLG_POR;
    lgSwedish: appID.Version.Language := TWLG_SWE;
    lgPolish: appID.Version.Language := TWLG_POLISH;
    lgGreek: appID.Version.Language := TWLG_GREEK;
    lgTurkish: appID.Version.Language := TWLG_TURKISH;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetLanguage: TLanguageType;

begin
  Result := lgDutch; // Initialize
  case appID.Version.Language of
    TWLG_DAN: Result := lgDanish;
    TWLG_DUT: Result := lgDutch;
    TWLG_ENG: Result := lgEnglish;
    TWLG_FIN: Result := lgFinnish;
    TWLG_FRN: Result := lgFrench;
    TWLG_GER: Result := lgGerman;
    TWLG_ITN: Result := lgItalian;
    TWLG_NOR: Result := lgNorwegian;
    TWLG_SPA: Result := lgSpanish;
    TWLG_USA: Result := lgAmerican;
    TWLG_RUSSIAN: Result := lgRussian;
    TWLG_POR: Result := lgPortuguese;
    TWLG_SWE: Result := lgSwedish;
    TWLG_POLISH: Result := lgPolish;
    TWLG_GREEK: Result := lgGreek;
    TWLG_TURKISH: Result := lgTurkish;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetManufacturer(mf: string);

var
  I, L: Integer;

begin
  FillChar(appID.Manufacturer, SizeOf(appID.Manufacturer), #0);
  L := Length(mf);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Manufacturer[I - 1] := mf[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetManufacturer: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.Manufacturer[I] <> #0 then
    repeat
      Result := Result + appID.Manufacturer[I];
      Inc(I);
    until appID.Manufacturer[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetProductname(pn: string);

var
  I, L: Integer;

begin
  FillChar(appID.Productname, SizeOf(appID.Productname), #0);
  L := Length(pn);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Productname[I - 1] := pn[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetProductName: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.ProductName[I] <> #0 then
    repeat
      Result := Result + appID.ProductName[I];
      Inc(I);
    until appID.ProductName[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetProductFamily(pf: string);

var
  I, L: Integer;

begin
  FillChar(appID.ProductFamily, SizeOf(appID.ProductFamily), #0);
  L := Length(pf);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.ProductFamily[I - 1] := pf[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetProductFamily: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.ProductFamily[I] <> #0 then
    repeat
      Result := Result + appID.ProductFamily[I];
      Inc(I);
    until appID.ProductFamily[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.ScanReady;

begin
  if Assigned(fScanReady) then
    fScanReady(Self);
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetDestination(dest: TTransferType);

begin
  fXfer := dest;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetDestination: TTransferType;

begin
  Result := fXfer;
end;
//----------------------------------------------------------------------

function UpCaseStr(const s: string): string;

var
  I, L: Integer;

begin
  Result := s;
  L := Length(Result);
  if L > 0 then
  begin
    for I := 1 to L do
      Result[I] := UpCase(Result[I]);
  end;
  // Result := s; // Minor bug, changed 23/05/03
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------

function GetWinDir: string;

var
  WD: array[0..MAX_PATH] of Char;
  L: WORD;

begin
  WD := #0;
  GetWindowsDirectory(WD, MAX_PATH);
  Result := StrPas(WD);
  L := Length(Result);
  // Remove the "\" if any
  if L > 0 then
    if Result[L] = '\' then
      Result := Copy(Result, 1, L - 1);
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------

procedure FileFindSubDir(const ffsPath: string;
  var ffsBo: Boolean);

var
  sr: TSearchRec;

begin
  if FindFirst(ffsPath + '\*.*', faAnyFile, sr) = 0 then
    repeat
      if sr.Name <> '.' then
        if sr.Name <> '..' then
          if sr.Attr and faDirectory = faDirectory then
          begin
            FileFindSubDir(ffsPath + '\' + sr.name, ffsBo);
          end
          else
          begin
            if UpCaseStr(ExtractFileExt(sr.Name)) = '.DS' then
              if UpCaseStr(sr.Name) <> 'WIATWAIN.DS' then
                ffsBo := True;
          end;
    until FindNext(sr) <> 0;
  // Error if SysUtils is not added in front of FindClose!
  SysUtils.FindClose(sr);
end;
//----------------------------------------------------------------------

function TTWAIN.IsTwainDriverAvailable: Boolean;

var
  sr: TSearchRec;
  s: string;
  Bo: Boolean;

begin
  // This routine might not be failsafe!
  // Under circumstances the twain drivers found in the directory
  // %WINDOWS%\TWAIN_32\*.ds and below could be not properly installed!
  Bo := False;
  s := GetWinDir + '\TWAIN_32';
  FileFindSubDir(s, Bo);
  Result := Bo;
end;
//---------------------------------------------------------------------

procedure TTWAIN.SaveDefaultSourceEntry;

var
  WinIni: TIniFile;

begin
  if sDefaultSource <> '' then
    Exit;
  WinIni := TIniFile.Create(Ini_File_Name);
  sDefaultSource := WinIni.ReadString('TWAIN', 'DEFAULT SOURCE', '');
  WinIni.Free;
end;
//---------------------------------------------------------------------

procedure TTWAIN.RestoreDefaultSourceEntry;

var
  WinIni: TIniFile;

begin
  if sDefaultSource = '' then
    Exit; // It is not changed by this component or it is not there...
  WinIni := TIniFile.Create(Ini_File_Name);
  WinIni.WriteString('TWAIN', 'DEFAULT SOURCE', sDefaultSource);
  WinIni.Free;
  sDefaultSource := '';
end;
//---------------------------------------------------------------------

procedure TTWAIN.InitTWAIN;

begin
  appID.ID := Application.Handle;
  fHwnd := Application.Handle;
  fLoadTwain; // Load TWAIN_32.DLL
  fOldOnMessageHandler := Application.OnMessage; // Save old pointer
  Application.OnMessage := fNewOnMessageHandler; // Set to our handler
  OpenDataSourceManager; // Open DS
end;
//---------------------------------------------------------------------

function TTWAIN.fLoadTwain: Boolean;

begin
  if HDSMDLL = 0 then
  begin
    HDSMDLL := LoadLibrary(TWAIN_DLL_Name);
    DSM_Entry := GetProcAddress(HDSMDLL, DSM_Entry_Name);
    // if @DSM_Entry = nil then
    //   raise ETwainError.Create(SErrDSMEntryNotFound);
  end;

  Result := (HDSMDLL <> 0);
end;
//---------------------------------------------------------------------

procedure TTWAIN.fUnloadTwain;

begin
  if HDSMDLL <> 0 then
  begin
    DSM_Entry := nil;
    FreeLibrary(HDSMDLL);
    HDSMDLL := 0;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.Condition2String(ConditionCode: TW_UINT16): string;

begin
  // Texts copied from PDF Documentation: Rework needed
  case ConditionCode of
    TWCC_BADCAP: Result :=
      'Capability not supported by source or operation (get,' + CrLf +
        'set) is not supported on capability, or capability had' + CrLf +
        'dependencies on other capabilities and cannot be' + CrLf +
        'operated upon at this time';
    TWCC_BADDEST: Result := 'Unknown destination in DSM_Entry.';
    TWCC_BADPROTOCOL: Result := 'Unrecognized operation triplet.';
    TWCC_BADVALUE: Result :=
      'Data parameter out of supported range.';
    TWCC_BUMMER: Result :=
      'General failure. Unload Source immediately.';
    TWCC_CAPUNSUPPORTED: Result := 'Capability not supported by ' +
      'Data Source.';
    TWCC_CAPBADOPERATION: Result := 'Operation not supported on ' +
      'capability.';
    TWCC_CAPSEQERROR: Result :=
      'Capability has dependencies on other capabilities and ' + CrLf +
        'cannot be operated upon at this time.';
    TWCC_DENIED: Result :=
      'File System operation is denied (file is protected).';
    TWCC_PAPERDOUBLEFEED,
      TWCC_PAPERJAM: Result :=
      'Transfer failed because of a feeder error';
    TWCC_FILEEXISTS: Result :=
      'Operation failed because file already exists.';
    TWCC_FILENOTFOUND: Result := 'File not found.';
    TWCC_LOWMEMORY: Result :=
      'Not enough memory to complete the operation.';
    TWCC_MAXCONNECTIONS: Result :=
      'Data Source is connected to maximum supported number of ' +
        CrLf + 'applications.';
    TWCC_NODS: Result :=
      'Data Source Manager was unable to find the specified Data ' +
        'Source.';
    TWCC_NOTEMPTY: Result :=
      'Operation failed because directory is not empty.';
    TWCC_OPERATIONERROR: Result :=
      'Data Source or Data Source Manager reported an error to the' +
        CrLf + 'user and handled the error. No application action ' +
        'required.';
    TWCC_SEQERROR: Result :=
      'Illegal operation for current Data Source Manager' + CrLf +
        'and Data Source state.';
    TWCC_SUCCESS: Result := 'Operation was succesful.';
  else
    Result := Format('Unknown condition %.04x', [ConditionCode]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSMCondition (idea: like RaiseLastWin32Error)            //
// Tries to get the status from the DSM and raises an exception      //
// with it.                                                          //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.RaiseLastDataSourceManagerCondition(module: string);

var
  status: TW_STATUS;

begin
  Assert(@DSM_Entry <> nil);
  if DSM_Entry(@appId, nil, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
    TWRC_SUCCESS then
    raise ETwainError.Create(ERR_STATUS)
  else
    raise ETwainError.CreateFmt(ERR_DSM, [module,
      Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSCondition                                              //
// same again, but for the actual DS                                 //
// (should be a method of DS)                                        //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.RaiseLastDataSourceCondition(module: string);

var
  status: TW_STATUS;

begin
  Assert(@DSM_Entry <> nil);
  if DSM_Entry(@appId, @dsID, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
    TWRC_SUCCESS then
    raise ETwainError.Create(ERR_STATUS)
  else
    raise ETwainError.CreateFmt(ERR_DSM, [module,
      Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDSM (idea: like Win32Check or GDICheck in Graphics.pas) //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.TwainCheckDataSourceManager(res: TW_UINT16;
  module: string);

begin
  if res <> TWRC_SUCCESS then
  begin
    if res = TWRC_FAILURE then
      RaiseLastDataSourceManagerCondition(module)
    else
      raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDS                                                      //
// same again, but for the actual DS                                 //
// (should be a method of DS)                                        //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.TwainCheckDataSource(res: TW_UINT16;
  module: string);

begin
  if res <> TWRC_SUCCESS then
  begin
    if res = TWRC_FAILURE then
      RaiseLastDataSourceCondition(module)
    else
      raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// CallDSMEntry:                                                     //
// Short form for DSM Calls: appId is not needed as parameter        //
///////////////////////////////////////////////////////////////////////

function TTWAIN.CallDataSourceManager(pOrigin: pTW_IDENTITY;
  DG: TW_UINT32;
  DAT: TW_UINT16;
  MSG: TW_UINT16;
  pData: TW_MEMREF): TW_UINT16;

begin
  Assert(@DSM_Entry <> nil);

  Result := DSM_Entry(@appID,
    pOrigin,
    DG,
    DAT,
    MSG,
    pData);
  if (Result <> TWRC_SUCCESS) and (DAT <> DAT_EVENT) then
  begin
  end;
end;
///////////////////////////////////////////////////////////////////////
// Short form for (actual) DS Calls. appId and dsID are not needed   //
// (this should be a DS class method)                                //
///////////////////////////////////////////////////////////////////////

function TTWAIN.CallDataSource(DG: TW_UINT32;
  DAT: TW_UINT16;
  MSG: TW_UINT16;
  pData: TW_MEMREF): TW_UINT16;

begin
  Assert(@DSM_Entry <> nil);
  Result := DSM_Entry(@appID,
    @dsID,
    DG,
    DAT,
    MSG,
    pData);
end;
///////////////////////////////////////////////////////////////////////
//  A lot of the following code is a conversion from the             //
//  twain example program (and some comments are copied, too)        //
//  (The error handling is done differently)                         //
//  Most functions should be moved to a DSM or DS class              //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.OpenDataSourceManager;

begin
  if not bDataSourceManagerOpen then
  begin
    Assert(appID.ID <> 0);
    if not fLoadTwain then
      raise ETwainError.Create(ERR_TWAIN_NOT_LOADED);

    // appID.Id := fhWnd;
    // appID.Version.MajorNum := 1;
    // appID.Version.MinorNum := 0;
    // appID.Version.Language := TWLG_USA;
    // appID.Version.Country  := TWCY_USA;
    // appID.Version.Info     := 'Twain Component';
    appID.ProtocolMajor := 1; // TWON_PROTOCOLMAJOR;
    appID.ProtocolMinor := 7; // TWON_PROTOCOLMINOR;
    appID.SupportedGroups := DG_IMAGE or DG_CONTROL;
    // appID.Productname      := 'HP ScanJet 5p';
    // appId.ProductFamily    := 'ScanJet';
    // appId.Manufacturer     := 'Hewlett-Packard';

    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_PARENT,
      MSG_OPENDSM,
      @fhWnd),
      'OpenDataSourceManager');

    bDataSourceManagerOpen := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.CloseDataSourceManager;

begin
  if bDataSourceOpen then
    raise ETwainError.Create(ERR_DSM_OPEN);

  if bDataSourceManagerOpen then
  begin
    // This call performs one important function:
    // - tells the SM which application, appID.id, is requesting SM to
    //   close
    // - be sure to test return code, failure indicates SM did not
    //   close !!

    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_PARENT,
      MSG_CLOSEDSM,
      @fhWnd),
      'CloseDataSourceManager');

    bDataSourceManagerOpen := False;

  end;
  fUnLoadTwain; // Loose the DLL

  if sDefaultSource <> '' then
    RestoreDefaultSourceEntry;

end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceManagerOpen: Boolean;

begin
  Result := bDataSourceManagerOpen;
end;
//---------------------------------------------------------------------

procedure TTWAIN.OpenDataSource;

begin
  Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');

  if not bDataSourceOpen then
  begin
    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_IDENTITY,
      MSG_OPENDS,
      @dsID),
      'OpenDataSource');
    bDataSourceOpen := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.CloseDataSource;

begin
  Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');
  if bDataSourceOpen then
  begin
    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_IDENTITY,
      MSG_CLOSEDS,
      @dsID),
      'CloseDataSource');
    bDataSourceOpen := False;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.EnableDataSource;

var
  twUI: TW_USERINTERFACE;

begin
  Assert(bDataSourceOpen, 'Data Source must be open');

  if not bDataSourceEnabled then
  begin
    FillChar(twUI, SizeOf(twUI), #0);

    twUI.hParent := fhWnd;
    twUI.ShowUI := fShowUI;
    twUI.ModalUI := True;

    TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
      DG_CONTROL,
      DAT_USERINTERFACE,
      MSG_ENABLEDS,
      @twUI),
      'EnableDataSource');

    bDataSourceEnabled := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.DisableDataSource;

var
  twUI: TW_USERINTERFACE;

begin
  Assert(bDataSourceOpen, 'Data Source must be open');

  if bDataSourceEnabled then
  begin
    twUI.hParent := fhWnd;
    twUI.ShowUI := TW_BOOL(TWON_DONTCARE8); (*!!!!*)

    TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
      DG_CONTROL,
      DAT_USERINTERFACE,
      MSG_DISABLEDS,
      @twUI),
      'DisableDataSource');

    bDataSourceEnabled := False;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceOpen: Boolean;

begin
  Result := bDataSourceOpen;
end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceEnabled: Boolean;

begin
  Result := bDataSourceEnabled;
end;
//---------------------------------------------------------------------

procedure TTWAIN.SelectDataSource;

var
  NewDSIdentity: TW_IDENTITY;
  twRC: TW_UINT16;

begin
  SaveDefaultSourceEntry;
  Assert(not bDataSourceOpen, 'Data Source must be closed');

  TwainCheckDataSourceManager(CallDataSourceManager(nil,
    DG_CONTROL,
    DAT_IDENTITY,
    MSG_GETDEFAULT,
    @NewDSIdentity),
    'SelectDataSource1');

  twRC := CallDataSourceManager(nil,
    DG_CONTROL,
    DAT_IDENTITY,
    MSG_USERSELECT,
    @NewDSIdentity);

  case twRC of
    TWRC_SUCCESS: dsID := NewDSIdentity; // log in new Source
    TWRC_CANCEL: ; // keep the current Source
  else
    TwainCheckDataSourceManager(twRC, 'SelectDataSource2');
  end;
end;
(*******************************************************************
  Functions from CAPTEST.C
*******************************************************************)

procedure TTWAIN.XferMech;

var
  cap: TW_CAPABILITY;
  pVal: pTW_ONEVALUE;

begin
  fXfer := xfNative; // Override
  cap.Cap := ICAP_XFERMECH;
  cap.ConType := TWON_ONEVALUE;
  cap.hContainer := GlobalAlloc(GHND, SizeOf(TW_ONEVALUE));
  Assert(cap.hContainer <> 0);
  try
    pval := pTW_ONEVALUE(GlobalLock(cap.hContainer));
    Assert(pval <> nil);
    try
      pval.ItemType := TWTY_UINT16;
      case fXfer of
        xfMemory: pval.Item := TWSX_MEMORY;
        xfFile: pval.Item := TWSX_FILE;
        xfNative: pval.Item := TWSX_NATIVE;
      end;
    finally
      GlobalUnlock(cap.hContainer);
    end;

    TwainCheckDataSource(CallDataSource(DG_CONTROL,
      DAT_CAPABILITY,
      MSG_SET,
      @cap),
      'XferMech');

  finally
    GlobalFree(cap.hContainer);
  end;

end;
///////////////////////////////////////////////////////////////////////

function TTWAIN.ProcessSourceMessage(var Msg: TMsg): Boolean;

var
  twRC: TW_UINT16;
  event: TW_EVENT;
  pending: TW_PENDINGXFERS;

begin
  Result := False;

  if bDataSourceManagerOpen and bDataSourceOpen then
  begin
    event.pEvent := @Msg;
    event.TWMessage := 0;

    twRC := CallDataSource(DG_CONTROL,
      DAT_EVENT,
      MSG_PROCESSEVENT,
      @event);

    case event.TWMessage of
      MSG_XFERREADY:
        begin
          case fXfer of
            xfNative: fNativeXfer;
            xfMemory: fMemoryXfer;
            xfFile: fFileXfer;
          end;
          TwainCheckDataSource(CallDataSource(DG_CONTROL,
            DAT_PENDINGXFERS,
            MSG_ENDXFER,
            @pending),
            'Check for Pending Transfers');

          if pending.Count > 0 then
            TwainCheckDataSource(CallDataSource(
              DG_CONTROL,
              DAT_PENDINGXFERS,
              MSG_RESET,
              @pending),
              'Abort Pending Transfers');

          DisableDataSource;
          CloseDataSource;
          ScanReady; // Event
        end;
      MSG_CLOSEDSOK,
        MSG_CLOSEDSREQ:
        begin
          DisableDataSource;
          CloseDataSource;
          ScanReady // Event
        end;
    end;

    Result := not (twRC = TWRC_NOTDSEVENT);
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.Acquire(aBmp: TBitmap);

begin
  // fOldOnMessageHandler := Application.OnMessage; // Save old pointer
  // Application.OnMessage := fNewOnMessageHandler; // Set to our handler
  // OpenDataSourceManager;                         // Open DS
  fBitmap := aBmp;
  OpenDataSourceManager;
  OpenDataSource;
  XferMech; // Must be written for xfMemory and xfFile
  EnableDataSource;
end;
//---------------------------------------------------------------------
// Must be written!

function TTWAIN.fMemoryXfer: Boolean;

var
  twRC: TW_UINT16;

begin
  Result := False;
  twRC := CallDataSource(DG_IMAGE,
    DAT_IMAGEMEMXFER,
    MSG_GET,
    nil);
  case twRC of
    TWRC_XFERDONE: Result := True;
    TWRC_CANCEL: ;
    TWRC_FAILURE: ;
  end;
end;
//---------------------------------------------------------------------
// Must be written!

function TTWAIN.fFileXfer: Boolean;

var
  twRC: TW_UINT16;

begin
  // Not yet implemented!
  Result := False;
  twRC := CallDataSource(DG_IMAGE,
    DAT_IMAGEFILEXFER,
    MSG_GET,
    nil);
  case twRC of
    TWRC_XFERDONE: Result := True;
    TWRC_CANCEL: ;
    TWRC_FAILURE: ;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fNativeXfer: Boolean;
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  function DibNumColors(dib: Pointer): Integer;

  var
    lpbi: PBITMAPINFOHEADER;
    lpbc: PBITMAPCOREHEADER;
    bits: Integer;

  begin
    lpbi := dib;
    lpbc := dib;

    if lpbi.biSize <> SizeOf(BITMAPCOREHEADER) then
    begin
      if lpbi.biClrUsed <> 0 then
      begin
        Result := lpbi.biClrUsed;
        Exit;
      end;
      bits := lpbi.biBitCount;
    end
    else
      bits := lpbc.bcBitCount;

    case bits of
      1: Result := 2;
      4: Result := 16; // 4?
      8: Result := 256; // 8?
    else
      Result := 0;
    end;
  end;
  // - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
var
  twRC: TW_UINT16;
  hDIB: TW_UINT32;
  hBmp: HBITMAP;
  lpDib: ^TBITMAPINFO;
  lpBits: PChar;
  ColorTableSize: Integer;
  dc: HDC;

begin
  Result := False;

  twRC := CallDataSource(DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hDIB);

  case twRC of
    TWRC_XFERDONE:
      begin
        lpDib := GlobalLock(hDIB);
        try
          ColorTableSize := (DibNumColors(lpDib) *
            SizeOf(RGBQUAD));

          lpBits := PChar(lpDib);
          Inc(lpBits, lpDib.bmiHeader.biSize);
          Inc(lpBits, ColorTableSize);

          dc := GetDC(0);
          try
            hBMP := CreateDIBitmap(dc, lpdib.bmiHeader,
              CBM_INIT, lpBits, lpDib^, DIB_RGB_COLORS);

            fBitmap.Handle := hBMP;

            Result := True;
          finally
            ReleaseDC(0, dc);
          end;
        finally
          GlobalUnlock(hDIB);
          GlobalFree(hDIB);
        end;
      end;
    TWRC_CANCEL: ;
    TWRC_FAILURE: RaiseLastDataSourceManagerCondition('Native Transfer');
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fNewOnMessageHandler(var Msg: TMsg;
  var Handled: Boolean);

begin
  Handled := ProcessSourceMessage(Msg);
  if Assigned(fOldOnMessageHandler) then
    fOldOnMessageHandler(Msg, Handled)
end;
//---------------------------------------------------------------------

procedure Register;

begin
  RegisterComponents('Samples', [TTWAIN]);
end;
//---------------------------------------------------------------------
end.
//---------------------------------------------------------------------


Component Download: mhtwain.zip