Using PIPES for messages

Problem/Question/Abstract:

A pipe is a section of shared memory that processes use for communication. The process that creates a pipe is the pipe server. A process that connects to a pipe is a pipe client. One process writes information to the pipe, then the other process reads the information from the pipe. (MSDN)

Answer:

WHAT PIPES ARE

Pipes are used by independent processes to communicate with each other. For every pipe there must be a server that creates and manages the pipe and one or more clients that use the pipe to interchange messages between each other.

Pipes can be used for communication of processes residing on the same computer as well as processes residing on different machines within a network.

WHEN CAN YOU USE PIPES

Basically all Windows NT 3.51 and up, as well as Win95 and up support named pipes. You will use named pipes only to transfer information between applications or similar. I would not use them for use within a single application or when the SendMessage/PostMessage routines will suffice.

Named Pipes will ensure the data transport between to processes - therefore you will use them when data transport is essential. Mailslots, similar to named pipes, will not ensure data transport between processes, are, however much more efficient.

BLOCKING AND NON-BLOCKING MODES

Pipes can be created supporting blocking and non-blocking modes. This is essential for three routines: ReadFile, WriteFile, and ConnectNamedPipe. These routines will not return during blocking-mode until data are read/sent. MS recommends the use of the blocking-mode.

THEORIE OF THIS SAMPLE

Your Pipe-Server will create a named pipe and wait for clients to access the pipe in order to send data. Once a Pipe-Client sends data, the Pipe-Server will open the Pipe to the Client, process the data, send the "answer", and closes the Pipe to the Client.

The server will close the pipe after every message processed.

NOTE

This is a simple sample for the use of Pipes only, as samples are hard to find anyway. I am working on a more complex one, this may, however take quite some time - depending on my spare time. :)

THE UNIT UPIPES.PAS

In this sample, the Pipe-Server will reverse the data send by the Pipe-Client as Response. No Range Checking is done!

unit uPipes;

interface

uses
  Classes, Windows;

const
  cShutDownMsg = 'shutdown pipe ';
  cPipeFormat = '\\%s\pipe\%s';

type
  RPIPEMessage = record
    Size: DWORD;
    Kind: Byte;
    Count: DWORD;
    Data: array[0..8095] of Char;
  end;

  TPipeServer = class(TThread)
  private
    FHandle: THandle;
    FPipeName: string;

  protected
  public
    constructor CreatePipeServer(aServer, aPipe: string; StartServer: Boolean);
    destructor Destroy; override;

    procedure StartUpServer;
    procedure ShutDownServer;
    procedure Execute; override;
  end;

  TPipeClient = class
  private
    FPipeName: string;
    function ProcessMsg(aMsg: RPIPEMessage): RPIPEMessage;
  protected
  public
    constructor Create(aServer, aPipe: string);

    function SendString(aStr: string): string;
  end;

implementation

uses
  SysUtils;

procedure CalcMsgSize(var Msg: RPIPEMessage);
begin
  Msg.Size :=
    SizeOf(Msg.Size) +
    SizeOf(Msg.Kind) +
    SizeOf(Msg.Count) +
    Msg.Count +
    3;
end;

{ TPipeServer }

constructor TPipeServer.CreatePipeServer(
  aServer, aPipe: string; StartServer: Boolean
  );
begin
  if aServer = '' then
    FPipeName := Format(cPipeFormat, ['.', aPipe])
  else
    FPipeName := Format(cPipeFormat, [aServer, aPipe]);
  // clear server handle
  FHandle := INVALID_HANDLE_VALUE;
  if StartServer then
    StartUpServer;
  // create the class
  Create(not StartServer);
end;

destructor TPipeServer.Destroy;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    // must shut down the server first
    ShutDownServer;
  inherited Destroy;
end;

procedure TPipeServer.Execute;
var
  I, Written: Cardinal;
  InMsg, OutMsg: RPIPEMessage;
begin
  while not Terminated do
  begin
    if FHandle = INVALID_HANDLE_VALUE then
    begin
      // suspend thread for 250 milliseconds and try again
      Sleep(250);
    end
    else
    begin
      if ConnectNamedPipe(FHandle, nil) then
      try
        // read data from pipe
        InMsg.Size := SizeOf(InMsg);
        ReadFile(FHandle, InMsg, InMsg.Size, InMsg.Size, nil);
        if
          (InMsg.Kind = 0) and
          (StrPas(InMsg.Data) = cShutDownMsg + FPipeName) then
        begin
          // process shut down
          OutMsg.Kind := 0;
          OutMsg.Count := 3;
          OutMsg.Data := 'OK'#0;
          Terminate;
        end
        else
        begin
          // data send to pipe should be processed here
          OutMsg := InMsg;
          // we'll just reverse the data sent, byte-by-byte
          for I := 0 to Pred(InMsg.Count) do
            OutMsg.Data[Pred(InMsg.Count) - I] := InMsg.Data[I];
        end;
        CalcMsgSize(OutMsg);
        WriteFile(FHandle, OutMsg, OutMsg.Size, Written, nil);
      finally
        DisconnectNamedPipe(FHandle);
      end;
    end;
  end;
end;

procedure TPipeServer.ShutDownServer;
var
  BytesRead: Cardinal;
  OutMsg, InMsg: RPIPEMessage;
  ShutDownMsg: string;
begin
  if FHandle <> INVALID_HANDLE_VALUE then
  begin
    // server still has pipe opened
    OutMsg.Size := SizeOf(OutMsg);
    // prepare shut down message
    with InMsg do
    begin
      Kind := 0;
      ShutDownMsg := cShutDownMsg + FPipeName;
      Count := Succ(Length(ShutDownMsg));
      StrPCopy(Data, ShutDownMsg);
    end;
    CalcMsgSize(InMsg);
    // send shut down message
    CallNamedPipe(
      PChar(FPipeName), @InMsg, InMsg.Size, @OutMsg, OutMsg.Size, BytesRead, 100
      );
    // close pipe on server
    CloseHandle(FHandle);
    // clear handle
    FHandle := INVALID_HANDLE_VALUE;
  end;
end;

procedure TPipeServer.StartUpServer;
begin
  // check whether pipe does exist
  if WaitNamedPipe(PChar(FPipeName), 100 {ms}) then
    raise Exception.Create('Requested PIPE exists already.');
  // create the pipe
  FHandle := CreateNamedPipe(
    PChar(FPipeName), PIPE_ACCESS_DUPLEX,
    PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT,
    PIPE_UNLIMITED_INSTANCES, SizeOf(RPIPEMessage), SizeOf(RPIPEMessage),
    NMPWAIT_USE_DEFAULT_WAIT, nil
    );
  // check if pipe was created
  if FHandle = INVALID_HANDLE_VALUE then
    raise Exception.Create('Could not create PIPE.');
end;

{ TPipeClient }

constructor TPipeClient.Create(aServer, aPipe: string);
begin
  inherited Create;
  if aServer = '' then
    FPipeName := Format(cPipeFormat, ['.', aPipe])
  else
    FPipeName := Format(cPipeFormat, [aServer, aPipe]);
end;

function TPipeClient.ProcessMsg(aMsg: RPIPEMessage): RPIPEMessage;
begin
  CalcMsgSize(aMsg);
  Result.Size := SizeOf(Result);
  if WaitNamedPipe(PChar(FPipeName), 10) then
    if not CallNamedPipe(
      PChar(FPipeName), @aMsg, aMsg.Size, @Result, Result.Size, Result.Size, 500
      ) then
      raise Exception.Create('PIPE did not respond.')
    else
  else
    raise Exception.Create('PIPE does not exist.');
end;

function TPipeClient.SendString(aStr: string): string;
var
  Msg: RPIPEMessage;
begin
  // prepare outgoing message
  Msg.Kind := 1;
  Msg.Count := Length(aStr);
  StrPCopy(Msg.Data, aStr);
  // send message
  Msg := ProcessMsg(Msg);
  // return data send from server
  Result := Copy(Msg.Data, 1, Msg.Count);
end;

end.

A SAMPLE USING UPIPES.PAS

Create a new application and add the unit uPipes.pas to the uses clause.
Add the following Controls to the Main Form


Checkbox: (Name: chkRunServer; Caption: Run Server)

Edit: (Name: edtServer)

Edit: (Name:edtTextToSend)

Button: (Name: btnSend)

Edit: (Name: edtResponse)



Add the private variable:

FServer: TPipeServer;

For the OnClick Event of the chkRunServer add the following code:

procedure TForm1.chkRunServerClick(Sender: TObject);
begin
  if chkRunServer.Checked then
  try
    FServer := TPipeServer.CreatePipeServer('', 'testit', True);
  except
    on E: Exception do
    begin
      ShowMessage(E.Message);
      chkRunServer.Checked := False;
    end;
  end
  else
  begin
    FServer.Destroy;
  end;
end;

For the OnClick Event of the btnSend add the following code:

procedure TForm1.btnSendClick(Sender: TObject);
begin
  with TPipeClient.Create(edtServer.Text, 'testit') do
  try
    edtResponse.Text := SendString(edtTextToSend.Text);
  finally
    Free;
  end;
end;

How to detect when the Windows Taskbar is moved

Problem/Question/Abstract:

Is it possible to detect when the Windows taskbar's position has been changed (moved or resized)? I'm sure you could just hook it and grab its messages (ABM_...), but is there a less involved way?

Answer:

The taskbar broadcasts a WM_SETTINGCHANGE message when it changes size or position.

private

procedure WMSettingChange(var msg: TWMSettingChange); message WM_SETTINGCHANGE;

procedure TForm1.WMSettingChange(var msg: TWMSettingChange);
var
  r: TRect;
begin
  if msg.Section <> nil then
    if StrIComp(msg.section, 'windows') = 0 then
    begin
      SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
      memo1.lines.add(format('Workarea is %d, %d:%d, %d', [r.left, r.top, r.right,
        r.bottom]));
    end;
end;

Create a message in MS Outlook using OLE

Problem/Question/Abstract:

How can I create a new message in MS Outlook using OLE?

Answer:

const
  olMailItem = 0;
var
  Outlook: OLEVariant;
  MailItem: Variant;
begin
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;

  MailItem := Outlook.CreateItem(olMailItem);
  MailItem.Recipients.Add('mshkolnik@scalabium.com');
  MailItem.Subject := 'your subject';
  MailItem.Body := 'Welcome to my homepage: http://www.scalabium.com';
  MailItem.Attachments.Add('C:\Windows\Win.ini');
  MailItem.Send;

  Oulook := Unassigned;
end;

I can save tasks and contacts to Outlook using OLE, but I need to be able to synchronize existing contacts. Do you have any ideas?

I think that you have a two methods with solutions

1.

var
  app, NameSpace, Contact: OLEVariant;
begin
  app := CreateOleObject(`Outlook.Application`);
  NameSpace := app.GetNameSpace(`MAPI`);
  Contact := NameSpace.GetItemFromID(EntryIDItem, EntryIDStore)
    {...}
end;

2. also you can navigate by contract items and compare the IDs. I understood that it`s not a good solution but without errors:)

app := CreateOleObject(`Outlook.Application`);
Contacts := app.GetDefaultFolder(10); {olFolderContacts}
for i := 0 to Items.Count - 1 do
begin
  Contact := Items[i];
  {...}
end;

How can I format the content of the body text to be HTML?

If you want to have html formatted message, use HTMLBody property instead Body. But not that this property is available starting from Outlook 98 only.

I need to parse through a certain folder's messages and put some data into a database based off what is in the  messages.  Suggestions?

Check my articles about MS Outlook programming:

http://www.scalabium.com/faq/dct0120.htm
http://www.scalabium.com/faq/dct0121.htm
http://www.scalabium.com/faq/dct0123.htm
and download a Delphi sample for these articles:
http://www.scalabium.com/faq/delphioutlook.zip

I try to execute this procedure in my program, i get the following error: project project1 raised exception class EOleSysError with message 'CoInitialize not called'.

You must call the OLEInitialize(nil) procedure from ComCtrls.pas unit. Some third-party suites unload this library from memory. Also additioanlly you must call it from every your thread if you'll use an OLE from this thread.

CPU window shows upon an exception

Problem/Question/Abstract:

How can I prevent the CPU window from popping up when an exception occurs?

Answer:

Set "ViewCPUOnException" to 0 in the registry, you find it here:

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Debugging

"Nonsense" error message "parameter mismatch for procedure"

Problem/Question/Abstract:

When I called a stored procedure from a trigger, I got a seemingly wrong error message "invalid request BLR at offset yyy, parameter mismatch for procedure XXX" but the passed parameters were fine.

Answer:

The solution is to handle the return value.
See the sample code below..

// this one does not work:
//  execute procedure update_petrochemical_feedstocks (1800024, 2001);

// this one does work:
declare variable v_sd integer;
declare variable v_fp integer;
declare variable v_ar integer;
begin
  select * from update_petrochemical_feedstocks(1800024, 2001)into: v_sd, : v_fp, : v_ar;
end

Debugging with conditional compiler directive

Problem/Question/Abstract:

How to use compiler directive {$IFOPT switch} for debugging ?

Answer:

The usual way of using the compiler directive is to first define using {$define debug} and use $IFDEF and $ENDIF

The method given below is similar with an additional advantage.

For example you can use the following code for debugging with GExperts

{$IFOPT D+}, DbugIntf{$ENDIF} //in the uses

{$IFOPT D+}
SendDebug('Data=' + InttoStr(TestVAlue));
  //whenever you require to display to the GExperts debug window
{$ENDIF}

The advantage of using $IFOPT D+ is that, the debug statements are automatically removed once you remove the debug info in the project option properties(Project Options->Compiler ->Debugging) .

Make hints stay up longer

Problem/Question/Abstract:

Make hints stay up longer

Answer:

To do this, set Application.HintHidePause to a larger number than its default of 2500 ms.

Getting the BIOS serial number

Problem/Question/Abstract:

Different BIOS manufacturers have placed the serial numbers and other BIOS information in different memory locations, so the code you can usually find in the net to get this information might work with some machines but not with others...

Answer:

For a simple copy-protection scheme we need to know whether the machine that is executing our application is the one where it was installed. We can save the machine data in the Windows Registry when the application is installed or executed for the first time, and then every time the application gets executed we compare the machine data with the one we saved to see if they are the same or not.

But, what machine data should we use and how do we get it? In a past issue we showed how to get the volume serial number of a logical disk drive, but normally this is not satisfying for a software developer since this number can be changed.

A better solution could be using the BIOS serial number. BIOS stands for Basic Input/Output System and basically is a chip on the motherboard of the PC that contains the initialization program of the PC (everything until the load of the boot sector of the hard disk or other boot device) and some basic device-access routines. Unfortunately, different BIOS manufacturers have placed the serial numbers and other BIOS information in different memory locations, so the code you can usually find in the net to get this information might work with some machines but not with others. However, most (if not all) BIOS manufacturers have placed the information somewhere in the last 8 Kb of the first Mb of memory, i.e. in the address space from $000FE000 to $000FFFFF. Assuming that "s" is a string variable, the following code would store these 8 Kb in it:

SetString(s, PChar(Ptr($FE000)), $2000); // $2000 = 8196

We can take the last 64 Kb to be sure we are not missing anything:

SetString(s, PChar(Ptr($F0000)), $10000); // $10000 = 65536

The problem is that it's ill-advised to store "large volumes" of data in the Windows Registry. It would be better if we could restrict to 256 bytes or less using some hashing/checksum technique. For example we can use the SHA1 unit (and optionally the Base64 unit) introduced in the issue #17 of the Pascal Newsletter:

http://www.latiumsoftware.com/en/pascal/0017.php3

The code could look like the following:

uses SHA1, Base64;

function GetHashedBiosInfo: string;
var
  SHA1Context: TSHA1Context;
  SHA1Digest: TSHA1Digest;
begin
  // Get the BIOS data
  SetString(Result, PChar(Ptr($F0000)), $10000);
  // Hash the string
  SHA1Init(SHA1Context);
  SHA1Update(SHA1Context, PChar(Result), Length(Result));
  SHA1Final(SHA1Context, SHA1Digest);
  SetString(Result, PChar(@SHA1Digest), sizeof(SHA1Digest));
  // Return the hash string encoded in printable characters
  Result := B64Encode(Result);
end;

This way we get a short string that we can save in the Windows Registry without any problems.

The full source code example corresponding to this article is available for download:

http://www.latiumsoftware.com/download/p0020.zip

The full source code example of this article is available for download:

http://www.latiumsoftware.com/download/p0020.zip

DISPLAYING BIOS INFORMATION

If we wanted to display the BIOS information we should parse the bytes to extract all null-terminated strings with ASCII printable characters at least 8-characters length, as it is done in the following function:

function GetBiosInfoAsText: string;
var
  p, q: pchar;
begin
  q := nil;
  p := PChar(Ptr($FE000));
  repeat
    if q <> nil then
    begin
      if not (p^ in [#10, #13, #32..#126, #169, #184]) then
      begin
        if (p^ = #0) and (p - q >= 8) then
        begin
          Result := Result + TrimRight(string(q)) + #13#10;
        end;
        q := nil;
      end;
    end
    else if p^ in [#33..#126, #169, #184] then
      q := p;
    inc(p);
  until p > PChar(Ptr($FFFFF));
  Result := TrimRight(Result);
end;

Then we can use the return value for example to display it in a memo:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.Lines.Text := GetBiosInfoAsText;
end;

Component Download: http://www.latiumsoftware.com/download/p0020.zip

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

Maarten de Haan:

Because the writer peeks into low mem, this probably will not work on all NT-like platforms. (WinNT, Win2000 and WinXP). On these platforms it is forbidden for an application to read / write outsite the space reserved and given to the application. If you do so, NTDLL.DLL will catch the reading / writing instruction and issue an error. It is also not possible to directly read or write to ports (like COM / LPT) under these operating systems.

It is very difficult to write a LPT- or COM-portdriver, which works on NT-like platforms. I have found some literature about it, in case you are interested:

http://www.wideman-one.com/gw/tech/Delphi/iopm/
http://www.torry.net/portaccess.htm
http://homepages.borland.com/efg2lab/Library/Delphi/IO/PortIO.htm

In order to communicate with ports under NT they all make use of a small program (*.sys) which is called by the main (Delphi) IO-program. This *.sys driver is not written in Delphi but in asm.

I have never seen a working method to read the BIOS date under NT-like platforms. But it can be done, I'm sure! The program: "Sandra" does it. See: http://www.sisoftware.co.uk/index.php?dir=&location=sware_dl&lang=en

Convert PDF to Text

Problem/Question/Abstract:

Convert PDF to Text

Answer:

If Reader is installed this code will do it for you:

{
courtesy DLoke on the Delphi-Talk mailing list
http://www.elists.org
}

procedure Tform1.PDF2Text(APDFFileName, ATextFileName: TFileName);
var
  App, AVDoc: Variant;
begin
  //create an instance. if no running instance is found a new one is started
  App := CreateOleObject('AcroExch.App');
  // App.Show;   //only if you want to..
  AVDoc := App.GetActiveDoc; //doc handle
  AVDoc.Open(APDFFileName, ''); //see note below
  //select all and copy to clipboard
  App.MenuItemExecute('Edit');
  App.MenuItemExecute('SelectAll');
  App.MenuItemExecute('Edit');
  App.MenuItemExecute('Copy');
  // Memo1 CAN be set to invisible
  // You need this in order to get it from
  // the clipboard into a text file
  Memo1.PasteFromClipboard;
  // Save the text to a file
  Memo1.Lines.SaveToFile(ATextFileName);
  App.Exit; //unless you want to leave it running.
end;

How to draw lines and a bitmap on a TStatusPanel

Problem/Question/Abstract:

How to draw lines and a bitmap on a TStatusPanel

Answer:

Example of drawing lines and BMP on StatusBar.Panels[1]. Assumes StatusBar is placed on form. Right click on StatusBar to invoke panels editor. Add three panels to StatusBar. Set Style for StatusBar.Panels[1] to psOwnerDraw. Add OnDrawPanel event shown below to StatusBar to draw bitmap on Panels[1].

unit ScreenStatusBarBMP;

interface

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

type
  TForm1 = class(TForm)
    StatusBar: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure StatusBarDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  StatusBar.Panels[0].Text := 'Zero';
  StatusBar.Panels[1].Text := 'One'; {ignored since psOwnerDraw style}
  StatusBar.Panels[2].Text := 'Two'
end;

procedure TForm1.StatusBarDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
  const Rect: TRect);
var
  Bitmap: TBitmap;
begin
  if Panel.Index = 1 then {not necessary if only one panel is owner drawn}
  begin
    {Draw red "X" in StatusPanel}
    StatusBar.Canvas.Pen.Color := clRed;
    StatusBar.Canvas.MoveTo(0, 0);
    StatusBar.Canvas.LineTo(Rect.Right - 1, Rect.Bottom - 1);
    StatusBar.Canvas.MoveTo(Rect.Left, Rect.Bottom - 1);
    StatusBar.Canvas.LineTo(Rect.Right - 1, Rect.Top);
    {Read Bitmap from file and display in middle of panel; In real app could get bitmap
    from resource file.}
    Bitmap := TBitmap.Create;
    try
      Bitmap.LoadFromFile('C:\Program Files\Common Files\Images\Buttons\Alarm.BMP');
      {Draw bitmap centered in panel}
      StatusBar.Canvas.Draw((Rect.Left + Rect.Right - Bitmap.Width) div 2,
        (Rect.Top + Rect.Bottom - Bitmap.Height) div 2, Bitmap);
    finally
      Bitmap.Free
    end;
  end;
end;

end.

A very simple way to create vertical labels

Problem/Question/Abstract:

A very simple way to create vertical labels

Answer:

Drop a TLabel on a form
Double-space the characters
Set Word Wrap := True;
Adjust height and width to your needs

Highlight an entire row in a TStringGrid (2)

Problem/Question/Abstract:

I have a TStringGrid component and I want change the color of the text in one row.

Answer:

Any kind of custom drawing in a TStringgrid requires a OnDrawCell handler (or overriding the DrawCell method in a derived grid class). Often this is not enough,however. If you base your special drawing on the active cell or its row or column you also need to make sure cells you previously drew in your custom manner are redrawn normal when the active cell moves, that the grid shows the special drawing only when it has focus and so on. This can get a bit complex, as shown by the sample below.

Note that is is simpler when you only customize the active cell, since this cell will be redrawn automatically when it is activated or deactivated.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, Grids;

const
  UM_INVALIDATEROW = WM_USER + 321;
type
  TForm1 = class(TForm)
    StatusBar: TStatusBar;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    StringGrid1: TStringGrid;
    Edit1: TEdit;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
      State: TGridDrawState);
    procedure StringGrid1Enter(Sender: TObject);
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var
      CanSelect: Boolean);
    procedure StringGrid1Exit(Sender: TObject);
  private
    { Private declarations }
    FGridActive: Boolean;
    procedure UMInvalidateRow(var msg: TMessage); message UM_INVALIDATEROW;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  dummy: Integer;

implementation

{$R *.DFM}

type
  TGridCracker = class(TStringgrid); { gives access to protected methods }

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  grid: TStringgrid;
begin
  {Task: color the current row}
  grid := Sender as TStringgrid;
  if FGridActive and (aRow = grid.Row) and (aCol >= grid.FixedCols) then
  begin
    grid.Canvas.brush.Color := clBlue;
    grid.canvas.font.color := clWhite;
    grid.canvas.FillRect(Rect);
    InflateRect(rect, -2, -2);
    grid.Canvas.TextRect(Rect, rect.left, rect.top, grid.cells[aCol, aRow]);
  end
  else if (gdSelected in State) and not grid.Focused then
  begin
    grid.Canvas.brush.Color := grid.color;
    grid.canvas.font.color := grid.font.color;
    grid.canvas.FillRect(Rect);
    InflateRect(rect, -2, -2);
    grid.Canvas.TextRect(Rect, rect.left, rect.top, grid.cells[aCol, aRow]);
  end;
end;

procedure TForm1.StringGrid1Enter(Sender: TObject);
begin
  if Sender is TStringgrid then
    with TGridCracker(sender) do
      PostMessage(self.handle, UM_INVALIDATEROW, Row, Integer(sender));
  FGridActive := true;
  { Cannot rely on grid.focused here, it is not yet true when the message send
  above is processed for some reason. }
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
var
  grid: TStringgrid;
begin
  grid := Sender as TStringgrid;
  if grid.Row <> aRow then
    PostMessage(handle, UM_INVALIDATEROW, grid.Row, Integer(grid));
  PostMessage(handle, UM_INVALIDATEROW, aRow, Integer(grid));
end;

procedure TForm1.UMInvalidateRow(var msg: TMessage);
begin
  TGridCracker(msg.lparam).InvalidateRow(msg.wparam);
end;

procedure TForm1.StringGrid1Exit(Sender: TObject);
begin
  if Sender is TStringgrid then
    with TGridCracker(sender) do
      PostMessage(self.handle, UM_INVALIDATEROW, Row, Integer(sender));
  FGridActive := false;
end;

end.

How to save a Paradox blob field to a file

Problem/Question/Abstract:

My Paradox Table has a BLOB field which contains BMP files (pasted into it). Now I want to access those BLOB values and save them into files... This should be hidden to the user, so I want to use a loop that accesses each record and retrieves that BLOB value. I have to use FieldByName("Cover") to do this. But then I'm lost between all of the formats of TField, TBlobField, etc.. What is the method to access those bmp BLOBs, and then save the picture part to a file? I can't use a DBImage or something similar as I am not showing them on screen during that operation, so I can't use the "Picture" property to retrieve it. It's directly pure table access. Also I have disabled the controls in the loop, so I can't even use a hidden DBImage to do this.

Answer:

Here's something that should get you started:

unit BmpToFromDB;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, FileCtrl, DBCtrls, ExtCtrls, Db, DBTables, Menus;

type
  TFrmBmpToFromDB = class(TForm)
    DriveComboBox1: TDriveComboBox;
    DirectoryListBox1: TDirectoryListBox;
    FileListBox1: TFileListBox;
    BtnWriteS: TButton;
    Image1: TImage;
    DataSource1: TDataSource;
    Table1: TTable;
    Table1TheLongInt: TIntegerField;
    Table1ABlobField: TBlobField;
    Table1Bytes1: TBlobField;
    Table1Bytes2: TBytesField;
    Table1B32_1: TBlobField;
    Table1B32_2: TBytesField;
    DBNavigator1: TDBNavigator;
    DBImage1: TDBImage;
    BtnReadS: TButton;
    BtnWrite: TButton;
    BtnRead: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure BtnWriteSClick(Sender: TObject);
    procedure BtnReadSClick(Sender: TObject);
    procedure BtnReadClick(Sender: TObject);
    procedure BtnWriteClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmBmpToFromDB: TFrmBmpToFromDB;

implementation

{$R *.DFM}

procedure TFrmBmpToFromDB.FormCreate(Sender: TObject);
begin
  Table1.Open;
end;

procedure TFrmBmpToFromDB.FormDestroy(Sender: TObject);
begin
  Table1.Close;
end;

procedure TFrmBmpToFromDB.BtnWriteSClick(Sender: TObject);
var
  f: integer;
  theBitmap: TBitmap;
  theBlobStream: TBlobStream;
begin
  for f := 0 to FileListBox1.Items.Count - 1 do
  begin
    Table1.Edit;
    theBlobStream := TBlobStream.Create(Table1B32_1, bmReadWrite);
    try
      theBitmap := TBitmap.Create;
      try
        theBitmap.LoadFromFile(FileListBox1.Items[f]);
        theBitmap.SaveToStream(theBlobStream);
      finally
        theBitmap.Free;
      end;
    finally
      theBlobStream.Free;
    end;
    Table1.Post;
    Table1.Next;
  end;
  Table1.First;
  DBImage1.Datasource := Datasource1;
end;

procedure TFrmBmpToFromDB.BtnWriteClick(Sender: TObject);
var
  f: integer;
  theBitmap: TBitmap;
begin
  for f := 0 to FileListBox1.Items.Count - 1 do
  begin
    Table1.Edit;
    theBitmap := TBitmap.Create;
    try
      TBlobField(Table1.FieldByName('B32_1')).LoadFromFile(FileListBox1.Items[f]);
    finally
      theBitmap.Free;
    end;
    Table1.Post;
    Table1.Next;
  end;
  Table1.First;
  DBImage1.Datasource := Datasource1;
end;

procedure TFrmBmpToFromDB.BtnReadSClick(Sender: TObject);
var
  tempBmp: TBitmap;
  theBlobStream: TBlobStream;
begin
  tempBmp := TBitmap.Create;
  try
    theBlobStream := TBlobStream.Create(TBlobField(Table1.FieldByName('B32_1')), bmRead);
    try
      tempBmp.LoadFromStream(theBlobStream);
      Image1.Picture.Bitmap.Assign(tempBmp);
    finally
      theBlobStream.Free;
    end;
  finally
    tempBmp.Free;
  end;
end;

procedure TFrmBmpToFromDB.BtnReadClick(Sender: TObject);
var
  tempBmp: TBitmap;
begin
  tempBmp := TBitmap.Create;
  try
    tempBmp.Assign(TBlobField(Table1.FieldByName('B32_1')));
    Image1.Picture.Bitmap.Assign(tempBmp);
  finally
    tempBmp.Free;
  end;
end;

end.

How to retrieve and display a TJPEGImage from a Paradox blob field

Problem/Question/Abstract:

How to retrieve and display a TJPEGImage from a Paradox blob field

Answer:

Solve 1:

Here's some code to fill a TImage on a form with a JPEGImage from a Paradox blob field:

var
  Stream1: TBlobStream;
  Photo: TJPEGImage;
begin
  Stream1 := TBlobStream.Create(Table1.FieldByName('YourFieldName') as TBlobField, bmRead);
  Photo := TJPEGImage.create;
  try
    Photo.LoadFromStream(Stream1);
    Image1.Picture.Assign(Photo);
  finally
    Stream1.Free;
    Photo.Free;
  end;
end;


Solve 2:

Here is an example showing use of the TJPEGImage to display JPEG images in a TImage component. The JPEG data is stored in a Paradox BLOB field, and this routine is executed when the record pointer is moved in the table in order to display each new record's BLOB field contents.

procedure TForm1.Table1AfterScroll(DataSet: TDataSet);
var
  MS: TMemoryStream;
  J1: TJPEGImage;
begin
  J1 := TJPEGImage.Create;
  MS := TMemoryStream.Create;
  try
    TBlobField(DataSet.Fields[1]).SaveToStream(MS);
    MS.Seek(soFromBeginning, 0);
    with J1 do
    begin
      PixelFormat := jf24Bit;
      Scale := jsFullSize;
      Grayscale := False;
      Performance := jpBestQuality;
      ProgressiveDisplay := True;
      ProgressiveEncoding := True;
      LoadFromStream(MS);
    end;
    Image1.Picture.Graphic.Assign(J1);
  finally
    J1.Free;
    MS.Free;
  end;
end;