Exporting an TImage contents to WMF format

Problem/Question/Abstract:

How can I export the content of a TImage for an image in the format of Clip Galleyr of Microsoft Office?

Answer:

I used this function once and she worked.

procedure ExportBMPtoWMF(Imagem: TImage; Dest: Pchar);
//
// Export an TImage contents to WMF format (Microsoft Clippart format file)
//
var
  Metafile: TMetafile;
  MetafileCanvas: TMetafileCanvas;
  DC: HDC;
  ScreenLogPixels: Integer;
begin
  Metafile := TMetafile.Create;
  try
    DC := GetDC(0);
    ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
    Metafile.Inch := ScreenLogPixels;
    Metafile.Width := Imagem.Picture.Bitmap.Width;
    Metafile.Height := Imagem.Picture.Bitmap.Height;
    MetafileCanvas := TMetafileCanvas.Create(Metafile, DC);
    ReleaseDC(0, DC);
    try
      MetafileCanvas.Draw(0, 0, Imagem.Picture.Bitmap);
    finally
      MetafileCanvas.Free;
    end;
    Metafile.Enhanced := FALSE;
    Metafile.SaveToFile(Dest);
  finally
    Metafile.Destroy;
  end;
end;

Create a locked file

Problem/Question/Abstract:

I was using temporary files on the root of the disk, but the user could try to modify it when my application was open and I didn't want that. Here's how to prevent it.

Answer:

Solve 1:

There are two ways of doing that, but one, with the use of Windows' APIs (LockFileEx and UnlockFileEx) using the parameter LOCKFILE_EXCLUSIVE_LOCK was not good for my case, so I found that:

Create the file with the OpenFile function and handle it:

hMyLockedFile := OpenFile('c:\variables.dat', ofStruct, OF_CREATE or OF_READWRITE or
  OF_SHARE_EXCLUSIVE);

Now, you can work with your file, but users cannot change it!

A last comment:
I found that in Win32 SDK Reference, so if you need to know more (and there's more to know: believe me!) you should use it!


Solve 2:

var
  SA: TSecurityAttributes;
  MyText: array[0..500] of char;
  BWritten: DWord;
  OK: Boolean;
begin
  MyText := 'Mark Halter' + chr(13) + Chr(10) + 'S�dstr. 6';

  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;

  Hndl := CreateFile('d:\temp\testfile.txt', // filename
    GENERIC_READ or GENERIC_WRITE, // read/write access
    0, // do not share file
    @SA, // Security Attributes
    CREATE_ALWAYS, // create file everytime
    FILE_ATTRIBUTE_NORMAL, // set normal attributs
    0);

  OK := WriteFile(Hndl,
    MyText,
    StrLen(MyText),
    BWritten,
    nil);

  CloseHandle(Hndl);
end;

Limit the form position to the screen's work area

Problem/Question/Abstract:

What's the best windows message to check if the Form's position is beyond the desktop area, when the user is moving it? How can I prevent the form/ mouse from moving when that happens?

Answer:

Solve 1:

You need a message that is send to the form before it moves and allows you to modfify the position it is about to move to before it actually does move. WM_MOVING or WM_WINDOWPOSCHANGING fit that bill. I would use the second, WM_MOVING will not be send if the user has switched off the "drag full window" option.

Limit a form to the screens workarea:

{ Private declarations }

procedure WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
  message WM_WINDOWPOSCHANGING;

procedure TForm1.WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
var
  r: TRect;
begin
  if ((SWP_NOMOVE or SWP_NOSIZE) and msg.WindowPos^.flags) < > (SWP_NOMOVE
    or SWP_NOSIZE) then
  begin
    {Window is moved or sized, get usable screen area}
    SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0);
    {Check if operation would move part of the window out of this area.
                If so correct position and, if required, size, to keep window fully inside
                the workarea. Note that simply adding the SWM_NOMOVE and SWP_NOSIZE flags
                to the flags field does not work as intended if full dragging of windows is
                disabled. In this case the window would snap back to the start position instead
                of stopping at the edge of the workarea, and you could still move the
    drag rectangle outside that area. }
    with msg.WindowPos^ do
    begin
      if x < r.left then
        x := r.left;
      if y < r.top then
        y := r.top;
      if (x + cx) > r.right then
      begin
        x := r.right - cx;
        if x < r.left then
        begin
          cx := cx - (r.left - x);
          x := r.Left;
        end;
      end;
      if (y + cy) > r.bottom then
      begin
        y := r.bottom - cy;
        if y < r.top then
        begin
          cy := cy - (r.top - y);
          y := r.top;
        end;
      end;
    end;
  end;
  inherited;
end;

Delphi 4.03 does not recognize TWMMOVING, because there is no message record type declared for it for some reason. That is easily fixed, however:

type
  TWmMoving = record
    Msg: Cardinal;
    fwSide: Cardinal;
    lpRect: PRect;
    Result: Integer;
  end;


Solve 2:

You can get this behaviour by handing the WM_MOVING message in the form. The message is send to the form before it actually moves, so you can modify the rectangle with the new form position before you pass the message on to the inherited handler.

For some reason messages.pas declares no message record for this message.

type
  TWmMoving = record
    Msg: Cardinal;
    fwSide: Cardinal;
    lpRect: PRect;
    Result: Integer;
  end;

Add a handler to your forms private section:

procedure WMMoving(var msg: TWMMoving); message WM_MOVING;

Implement it as:

procedure TFormX.WMMoving(var msg: TWMMoving);
var
  r: TRect;
begin
  r := Screen.WorkareaRect;
  {Compare the new form bounds in msg.lpRect^ with r and modify it if necessary}
  if msg.lprect^.left < r.left then
    OffsetRect(msg.lprect^, r.left - msg.lprect^.left, 0);
  if msg.lprect^.top < r.top then
    OffsetRect(msg.lprect^, 0, r.top - msg.lprect^.top);
  if msg.lprect^.right > r.right then
    OffsetRect(msg.lprect^, r.right - msg.lprect^.right, 0);
  if msg.lprect^.bottom > r.bottom then
    OffsetRect(msg.lprect^, 0, r.bottom - msg.lprect^.bottom);
  inherited;
end;

Is font "X" installed?

Problem/Question/Abstract:

How to determine if a font is installed

Answer:

You can just use this function, or put the code directly wherever you need it

function FontInstalled(const FontName: string): Boolean;
begin
  Result := Screen.Fonts.IndexOf(FontName) > 0
end;

then just call it

if not (FontInstalled('Pilobolus')) then
begin
  ShowMessage('Pilobolus font is not installed!')
    //you can do stuff here to install it, or whatever you need...
end;

TStringGrid functions (Delete, Insert, Sort)

Problem/Question/Abstract:

How to insert, delete or sort columns in StringGrids

Answer:

Solve 1:

procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer);
var
  Column: Integer;
begin
  if DelColumn <= StrGrid.ColCount then
  begin
    for Column := DelColumn to StrGrid.ColCount - 1 do
      StrGrid.Cols[Column - 1].Assign(StrGrid.Cols[Column]);
    StrGrid.ColCount := StrGrid.ColCount - 1;
  end;
end;

procedure GridAddColumn(StrGrid: TStringGrid; NewColumn: Integer);
var
  Column: Integer;
begin
  StrGrid.ColCount := StrGrid.ColCount + 1;
  for Column := StrGrid.ColCount - 1 downto NewColumn do
    StrGrid.Cols[Column].Assign(StrGrid.Cols[Column - 1]);
  StrGrid.Cols[NewColumn - 1].Text := '';
end;

procedure GridSort(StrGrid: TStringGrid; NoColumn: Integer);
var
  Line, PosActual: Integer;
  Row: TStrings;
begin
  Renglon := TStringList.Create;
  for Line := 1 to StrGrid.RowCount - 1 do
  begin
    PosActual := Line;
    Row.Assign(TStringlist(StrGrid.Rows[PosActual]));
    while True do
    begin
      if (PosActual = 0) or (StrToInt(Row.Strings[NoColumn - 1]) >=
        StrToInt(StrGrid.Cells[NoColumn - 1, PosActual - 1])) then
        Break;
      StrGrid.Rows[PosActual] := StrGrid.Rows[PosActual - 1];
      Dec(PosActual);
    end;
    if StrToInt(Row.Strings[NoColumn - 1]) < StrToInt(StrGrid.Cells[NoColumn - 1,
      PosActual]) then
      StrGrid.Rows[PosActual] := Row;
  end;
  Renglon.Free;
end;


Solve 2:

Had a few problems with range errors with the algorythms. On Delete or Add columns it is desirable to keep the widths of the columns as they are moved. Add column could also take the width of the new column (or default to DefaultColWidth if zero). I also had range errors in the Grid sort. On a large grid a Quicksort routine would be more desirable.

The Quicksort routine could take various sort modes as a parameter eg. Alpha,Double,Integer etc. (have supported only these 3 in demo, but it's easy to see how to incorporate more). The quick sort should also take "from row - to row" as parameters as we normally would not want to sort the header, or just a sub range may be required to be
sorted.

All in all though, some nice ideas for an extended stringgrid class, couple with DeleteRow, AddRow, LoadFromQuery etc.

procedure RemoveColumn(SG: TStringGrid; ColNumber: integer);
var
  Column: integer;
begin
  ColNumber := abs(ColNumber);

  if ColNumber <= SG.ColCount then
  begin
    for Column := ColNumber to SG.ColCount - 2 do
    begin
      SG.Cols[Column].Assign(SG.Cols[Column + 1]);
      SG.Colwidths[Column] := SG.Colwidths[Column + 1];
    end;
    SG.ColCount := SG.ColCount - 1;
  end;
end;

procedure AddColumn(SG: TStringGrid; AtColNumber: integer;
  ColWidth: integer = 0);
var
  Column: integer;
  Wdth: integer;
begin
  AtColNumber := abs(AtColNumber);
  SG.ColCount := SG.ColCount + 1;
  if abs(ColWidth) = 0 then
    Wdth := SG.DefaultColWidth
  else
    Wdth := ColWidth;

  if AtColNumber <= SG.ColCount then
  begin
    for Column := SG.ColCount - 1 downto AtColNumber + 1 do
    begin
      SG.Cols[Column].Assign(SG.Cols[Column - 1]);
      SG.Colwidths[Column] := SG.Colwidths[Column - 1];
    end;

    SG.Cols[AtColNumber].Text := '';
    SG.Colwidths[AtColNumber] := Wdth;
  end;
end;


Solve 3:

type
  TStringGridExSortType = (srtAlpha, srtInteger, srtDouble);

procedure GridSort(SG: TStringGrid; ByColNumber, FromRow, ToRow: integer;
  SortType: TStringGridExSortType = srtAlpha);
var
  Temp: TStringList;

  function SortStr(Line: string): string;
  var
    RetVar: string;
  begin
    case SortType of
      srtAlpha: Retvar := Line;
      srtInteger: Retvar := FormatFloat('000000000', StrToIntDef(trim(Line), 0));
      srtDouble:
        try
          Retvar := FormatFloat('000000000.000000', StrToFloat(trim(Line)));
        except
          RetVar := '0.00';
        end;
    end;

    Result := RetVar;
  end;

  // Recursive QuickSort
  procedure QuickSort(Lo, Hi: integer; CC: TStrings);

    procedure Sort(l, r: integer);
    var
      i, j: integer;
      x: string;
    begin
      i := l;
      j := r;
      x := SortStr(CC[(l + r) div 2]);
      repeat
        while SortStr(CC[i]) < x do
          inc(i);
        while x < SortStr(CC[j]) do
          dec(j);
        if i <= j then
        begin
          Temp.Assign(SG.Rows[j]); // Swap the 2 rows
          SG.Rows[j].Assign(SG.Rows[i]);
          SG.Rows[i].Assign(Temp);
          inc(i);
          dec(j);
        end;
      until i > j;
      if l < j then
        sort(l, j);
      if i < r then
        sort(i, r);
    end;

  begin {quicksort}
    Sort(Lo, Hi);
  end;

begin
  Temp := TStringList.Create;
  QuickSort(FromRow, ToRow, SG.Cols[ByColNumber]);
  Temp.Free;
end;

Speech Part 1 - How to Add "Text to Speech" (Speech Synthesis) to your Delphi Apps

Problem/Question/Abstract:

How can I get my application to read text?

Answer:

On Aug 11, 2001 Microsoft released the SAPI 5.1 SDK. This is significant because SAPI 5.1  is fully automated. That is you can use it from any language that supports OLE automation. These are not Active X controls and can be either early or late bound.

In this article I&#8217;m going to show you how to get and install the SAPI 5.1 SDK. Then I&#8217;m going to show how to use the SDK convert text to synthesized speech in a Delphi application. The synthesized speech is played over you computers speakers. I test this in Delphi 5 and 6.

To get SAPI 5.1 you need to go to Microsoft&#8217;s Speech.net Technologies web site at

http://www.microsoft.com/speech

and follow the link to the download. Right next to the download link is the release notes link. READ THE RELEASE NOTE! Especially if your development machine is using a default language other than US English.

If you are running a beta version of the XP operating system you might have some problems. This is because SAPI 5.1 is built into XP and the most recent public beta of XP as of this writing (RC 2) includes an earlier version of SAPI 5.1. Don&#8217;t try to install the release version of SAPI 5.1 into XP, it will not work.

Once you read the release notes follow the link to the Speech SDK 5.1 Download page. In most cases all you need to download is the link labeled &#8220;Speech SDK 5.1 (68 MB). This contains the SDK, the documentation and the free Microsoft English text to speech and speech recognition engines. The download is very large, 68 MB, so unless you have a high speed connection to the internet you might want to order the SDK CD from Microsoft.

&#8230;. Time passes while you download or wait for the postman &#8230;.

Ok, now you have the SAPI 5.1 SDK. Run the speechsdk51.exe to install it on your development system.

DELPHI 6 Users IMPORTANT
There is a bug in the type library import in Delphi 6 see article "Delphi 6 - Imported Automation Events Bug". This sample will still work with the unit created by the type libary import in Delphi 6 but only because none of the events for the component are used. If you want to use any of the SPVoice events you will need to read article "Delphi 6 - Imported Automation Events Bug".

What you need to do now is make Delphi aware of the new SAPI automation objects. To do this, start up Delphi 5 or 6 (I didn&#8217;t try earlier versions) and go to Project | Import Type Library. In the Import Type Library dialog highlight &#8220;Microsoft Speech Object Library (Version 5.1)&#8221;. If you don&#8217;t find this in the list then something&#8217;s wrong with the installation of SAPI 5.1.

Delphi is going to want to put the SAPI components on your ActiveX palette page. I recommend you put these on a new palette page called &#8220;SAPI 5&#8221; since the number of components installed is large (19). You may also want to choose a &#8220;Unit dir name&#8221; of something other than the default. Make sure the &#8220;Generate Component Wrapper&#8221; check box is checked and press the >Install< button.

In the Install dialog choose the &#8220;Into new package&#8221; tab and in the &#8220;File name:&#8221; field give a package name like &#8220;SAPI5.dpk&#8221; press the browse button and make sure the dpk is created in the same directory where you created the components. Actually this isn&#8217;t completely necessary it just helps keep things together. In the Install dialog&#8217;s Description field give some meaningful description like &#8220;SAPI 5 automation components&#8221;. Press OK

Press yes in the confirm dialog and the new components will be created and installed.

If you now look in the directory you specified for the components you should find SpeechLib_TLB.pas (and dcr) which contains all the component code as well as interface, const, type and other useful information. This is your most valuable piece of documentation on the SDK. I&#8217;ve found it even better than the Microsoft SAPI 5.1 documentation which is pretty good. This directory should also contain (if you followed the above instructions) the SAPI5.dpk which is your package source.

If you go to the far eastern end of your component palette you should find the new SAPI5 palette page with its 19 speech components.

Now for the fun part.

Let&#8217;s make an application that can synthesize speech. In Delphi start a new application and drop a button on the form. On the SAPI5 palette page find the SpVoice component and drop it on the form. On my machine this component is the 5th one reading from left to right.

Now create an onClick event for you button that looks something like this;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SpVoice1.Speak('Hello world!', SVSFDefault);
end;

Run the program and press the button. Cool hu?

At this level it&#8217;s amazingly simple. The SPVoice objects Speak method is very powerful. This power comes from the second parameter. For the above example I choose to use the default mode which causes the speak method to return only when the synthesis is complete, not to purge pending speech requests, to respond to special XML control tags embedded in the text.

The SDKs documentation is contained in sapi.chm which you will find in the  \Program Files\Microsoft Speech SDK 5.1\Docs\Help directory.

Sapi.chm contains a lot of information. To go directly to the meat of the subject go to the last folder on the outlines 1st level titled Automation and go down to SPVoice and then to the Speak method read what&#8217;s there and also be sure to follow the link to the SpeechVoiceSpeakFlags info. You will find that in addition to just speaking passed in text that can also do much more some of the more interesting flags are;

Pass in a file name and speak the text in the file. (SVSFIsFilename)
Make the function either return immediately (asynchronously) or only after the synthesis is complete(synchronously). If you speak asynchronously there are events available to fire when the speech is done. (SVSFlagsAsync)
Embed flags in the text that can control various aspects of the synthesis like pitch, rate, emphasis, and much more (see the included White Paper titled &#8220;XML TTS Tutorial&#8221;). I found this feature a bit addicting as I attempted to make the synthesized voice sing.( SVSFIsXML)

One interesting thing I found (but not documented) was that you can speak a web sites title by setting the flag to SVSFIsFilenam and passing a URL. If you are connected to the internet, try replacing the speak line in the sample line with

SpVoice1.Speak('http://www.o2a.com', SVSFIsFilename);

And run it.

Even more bizarre is you can use the speak method to play wav files. Try

SpVoice1.Speak('C:\WINNT\MEDIA\Windows Logon Sound.wav', SVSFIsFilename);

There&#8217;s a lot more to SAPI then text to speech and there&#8217;s more to text to speech then what I&#8217;ve covered here. Hopefully this will be the first of a number of articles on SAPI but I&#8217;ll only do them if you&#8217;re interested so please be sure to comment. Also I&#8217;m completely open to suggestions on what you&#8217;d like to see next (if anything at all).

If you want to talk privately I&#8217;m at alecb@o2a.com.

Debug Delphi 3 experts with Delphi 3

Problem/Question/Abstract:

Debug Delphi 3 experts with Delphi 3

Answer:

Delphi 3 has a new feature "debug DLLs". It can be used to debug experts with the internal debugger. Just follow these simple steps, and debugging an expert can be fun:

Make sure that the expert is not installed. If there is this entry  \CURRENT_USER\software\Delphi\3.0\experts, myexpert=\projects\myexpert\expert.dll rename this entry to "expert.xxx". (don't delete it, you'll need it later). Otherwise, you cannot compile a new version.

Run Delphi, open your expert's project as used, compile it and set the break points you think you need.

Go to the menu item run | parameters. This is the new Delphi 3 feature mentioned above.

Surprise: the host application is Delphi itself! So, next to the field "host app", enter something like e:\Programs\delphi3\bin\delphi32.exe (with path)

Second trick: now we install the expert... If you have "expert.xxx" installed, rename that to "expert.dll". This will be used by any Delphi instance started from now on.

Run "your application" (= Delphi 3) using menu item run | run. If you have enough RAM, Delphi is loaded and this instance will have your expert installed. Activate the expert, you'll have the possibility to use the comfort of the first instance's internal debugger.

Close the right instance of Delphi - and you can modify/ recompile etc. your expert.

Getting a page from a webserver and put it in a string variable

Problem/Question/Abstract:

How do I get a page from a webserver only using TClientSocket?

Answer:

Attach the following event-handlers to your TClientSocket. It gets the file from the server and puts it in the FText string variable. Btw, it doesn't remove the header that is also send by the webserver.
Don't forget to setup your Socket object with a correct server adress. Set port to 80. And open it with "Socket.Open;".
I wrote this as part of an AutoUpdate feature in one of my applications.

const
  WebPage = '/index.html';
var
  FText: string;

procedure TForm1.SocketWrite(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendText('GET ' + Webpage + ' HTTP/1.0'#10#10);
end;

procedure TForm1.SocketRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := FText + Socket.ReceiveText
end;

procedure TForm1.SocketConnecting(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := '';
end;

procedure TForm1.SocketDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  { --- }
  { HERE YOU CAN PROCESS YOUR FText !!! }
  { --- }
end;

procedure TForm1.SocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode := 0; { Just ignore errors }
end;

Get the screen coordinates of the rectangle in which web pages are rendered in IE

Problem/Question/Abstract:

I am writing a Delphi application that needs to know the screen coordinates (top, left) of where the IE 'browser section' starts. What I mean by 'browser section' is the rectangle where web pages are rendered - not where the IE window is. I can find out where the IE window is, and where the client coordinates start, but not the where the 'browser section' starts. I want to lay my Delphi window precisely on top of the where the browser section is. But depending on how many toolbars the users is displaying where this browser section may start is a mystery.

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    Label1: TLabel;
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure FindIEBrowserWindowHandle;
  end;

var
  Form1: TForm1;
  IEBrowserWindowHandle: THandle;

implementation

{$R *.DFM}

function EnumIEChildProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
var
  tmpS: string;
  theClassName: string;
  theWinText: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + ' "' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('Explorer_Server', tmpS) > 0 then
  begin
    IEBrowserWindowHandle := AHandle;
  end;
end;

function IEWindowEnumProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
{callback for EnumWindows}
var
  theClassName: string;
  theWinText: string;
  tmpS: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + ' "' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('IEFrame', tmpS) > 0 then
  begin
    EnumChildWindows(AHandle, @EnumIEChildProc, longInt(0));
  end;
end;

procedure TForm1.FindIEBrowserWindowHandle;
begin
  Screen.Cursor := crHourGlass;
  try
    EnumWindows(@IEWindowEnumProc, LongInt(0));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  caption: array[0..127] of Char;
  s: string;
  R: TRect;
begin
  FindIEBrowserWindowHandle;
  if IEBrowserWindowHandle > 0 then
  begin
    GetWindowRect(IEBrowserWindowHandle, R);
    s := 'IE Browser Window located at: ' + IntToStr(R.Top) + ', ' + IntToStr(R.Left)
      + ', ' + IntToStr(R.Bottom) + ', ' + IntTOStr(R.Right);
    Label1.Caption := s;
  end
  else
    label1.Caption := 'Not Found';
end;

end.

Create a watermark

Problem/Question/Abstract:

How to create a watermark

Answer:

Solve 1:

How it works: On a hidden image, sized to suit the final text, print text in black. Then by using the Pixels[] property, interrogate the hidden image. Where a pixel is black, adjust the red/green/blue settings of a corresponding pixel in the photograph. The following procedure MakeWatermark will do just that, placing the text where you want it.

{ ... }
type
  wmType = (wmTopLeft, wmTopCentre, wmTopRight, wmCentreLeft, wmCentre, wmCentreRight,
    wmBottomLeft, wmBottomCentre, wmBottomRight, wmRndXRndY, wmSetXRndY,
    wmRndXSetY, wmSetXSetY);

function Limit256(I: integer): integer;
begin
  if I < 0 then
    I := 0;
  if > 255 then
    I := 255;
  Limit256 := I;
end;

function ColourAdjust(Z, R, G, B: integer): integer;
var
  B1, G1, R1: integer;
begin
  {shl 1 = Multiply by 2}{TColor}
  R1 := Limit256((Z and $000000FF) + R);
  G1 := Limit256(((Z and $0000FF00) shr 8) + G);
  B1 := Limit256(((Z and $00FF0000) shr 16) + B);
  ColourAdjust := (B1 shl 16) + (G1 shl 8) + R1;
end;

procedure TForm1.MakeWatermark(const wmMode: wmType; var vImage: TImage;
  const Txt, FntName: string; FntStyle: TFontStyles; FntSize, X, Y, AdjRed, AdjGrn,
    AdjBlu: integer);
var
  I, J, IH, IW, TH, TW, Z: integer;
  TmpImg: TImage;
begin
  TmpImg := TImage.Create(Form1);
  TmpImg.Picture := nil;
  with TmpImg do
  begin
    Canvas.Pen.Color := clWhite;
    Canvas.Pen.Style := psSolid;
    Canvas.Font.Name := FntName;
    Canvas.Font.Color := clBlack;
    Canvas.Font.Style := FntStyle;
    if FntSize > 0 then
    begin
      Canvas.Font.Size := FntSize;
      TW := Canvas.TextWidth(Txt);
      TH := Canvas.TextHeight(Txt);
    end
    else
    begin
      TW := vImage.Width;
      TH := vImage.Height;
      I := 7;
      repeat
        inc(I);
        Canvas.Font.Size := I;
      until
        (Canvas.TextWidth(Txt) > TW) or (Canvas.TextHeight(Txt) > TH);
      dec(I);
      Canvas.Font.Size := I;
      TW := Canvas.TextWidth(Txt);
      TH := Canvas.TextHeight(Txt);
    end;
  end;
  TmpImg.Width := TW;
  TmpImg.Picture.Bitmap.Width := TW;
  TmpImg.Height := TH;
  TmpImg.Picture.Bitmap.Height := TH;
  TmpImg.Repaint;
  TmpImg.Canvas.TextOut(0, 0, Txt);
  TmpImg.Refresh;
  if TmpImg.Canvas.Pixels[0, 0] < 0 then
    ShowMessage('TmpImg pixel error.');
  if vImage.Picture.Bitmap.Canvas.Pixels[0, 0] < 0 then
    ShowMessage('vImage pixel error.');
  IW := vImage.Picture.Width;
  IH := vImage.Picture.Height;
  case wmMode of
    wmTopLeft:
      begin
        X := 0;
        Y := 0;
      end;
    wmTopCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := 0;
      end;
    wmTopRight:
      begin
        X := IW - TW;
        Y := 0;
      end;
    wmCentreLeft:
      begin
        X := 0;
        Y := IH div 2 - TH div 2;
      end;
    wmCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := IH div 2 - TH div 2;
      end;
    wmCentreRight:
      begin
        X := IW - TW;
        Y := IH div 2 - TH div 2;
      end;
    wmBottomLeft:
      begin
        X := 0;
        Y := IH - TH;
      end;
    wmBottomCentre:
      begin
        X := IW div 2 - TW div 2;
        Y := IH - TH;
      end;
    wmBottomRight:
      begin
        X := IW - TW;
        Y := IH - TH;
      end;
    wmRndXRndY:
      begin
        X := Random(IW - TW);
        Y := Random(IH - TH);
      end;
    wmSetXRndY:
      begin
        {X passed}
        Y := Random(IH - TH);
      end;
    wmRndXSetY:
      begin
        X := Random(IW - TW);
        {Y passed}
      end;
    wmSetXSetY:
      begin
        {X passed}
        {Y passed}
        DoNothing;
      end;
  end;
  for I := 0 to TW do
    for J := 0 to TH do
      if TmpImg.Canvas.Pixels[I, J] = clBlack then
      begin
        Z := vImage.Picture.Bitmap.Canvas.Pixels[I + X, J + Y];
        Z := ColourAdjust(Z, AdjRed, AdjGrn, AdjBlu);
        vImage.Picture.Bitmap.Canvas.Pixels[I + X, J + Y] := Z;
      end;
  TmpImg.Free;
end;

Call MakeWatermark with the following parameters:

watermark type eg wmTopLeft places the watermark in the top left of the image;
Image to be watermarked;
Text to be shown;
Name of the font to use;
style of the font eg [fsBold,fsItalic];
size of the text, use -1 for maximum size;
X and Y co-ordinates (used only in  wmSetXRndY, wmRndXSetY and wmSetXSetY, X being only used where type contains "SetX";
adjustments for Red, Green, and Blue, negative = darken.

If the image you wish to watermark objects to reading the pixels then an error message will be given and the procedure exited.


Solve 2:

If you sport a company (or other) logo, you might want to display it on your program's GUI, but unobtrusively and matching the user's color preferences. This can be done by displaying it as a "watermark" with colors only slightly different from the background color. All you have to do is to add a Timage with a 2- or 3-color bitmap. One color (usually the one at the lower left corner of the bitmap) becomes the transparent color (be sure to set Image.Transparent := True), the other one or two are changed at runtime to the watermark colors:

procedure TAboutBox.FormCreate(Sender: TObject);
var
  clWatermd: TColor;
  clWaterml: TColor;
begin
  {Set watermark colors slightly off parent}
  clWatermd := ColorToRGB(Panel1.Color) - $101010;
  clWaterml := ColorToRGB(Panel1.Color) + $080808;
  with Image2 do
  begin
    {Modify moon color to watermark color}
    Canvas.Brush.Color := clWaterml;
    Canvas.FloodFill(20, 20, clSilver, fsSurface);
    Canvas.FloodFill(51, 42, clSilver, fsSurface);
    {Modify wolf color to watermark color}
    Canvas.Brush.Color := clWatermd;
    Canvas.FloodFill(60, 60, clBlack, fsSurface);
  end;
end;

In the example above, clSilver in the original bitmap is displayed slightly brighter than the background, clBlack slightly darker. The point coordinates lie somewhere within the colored areas, separate areas must all be separately handled. On 256 color displays, the watermark colors may be 'slightly' off the desired effect, so use is only recommended on higher color resolutions.

Get the HTML code of the active document of a TWebBrowser component

Problem/Question/Abstract:

How to get the HTML code of the active document of a TWebBrowser component

Answer:

Solve 1:

procedure GetHtmlCode(WebBrowser: TWebBrowser; FileName: string);
var
  htmlDoc: IHtmlDocument2;
  PersistFile: IPersistFile;
begin
  htmlDoc := WebBrowser.document as IHtmlDocument2;
  PersistFile := HTMLDoc as IPersistFile;
  PersistFile.save(StringToOleStr(FileName), true);
end;


Solve 2:

This function returns the body as a string, but, maybe, all you need is the InnerText from IHTMLDocument2.

function TFrameBook.GetFullHTMLBody(): string;
var
  S: TStringStream;
begin
  S := TStringStream.Create('');
  try
    (WebBrowser1.Document as IPersistStreamInit).Save(TStreamAdapter.Create(S), True);
    Result := S.DataString;
  finally
    S.Free;
  end;
end;

Demo of file copying (TFileStream) in a thread (TThread)

Problem/Question/Abstract:

Demo of file coping (TFileStream) in a thread (TThread). It also resumes copying of files that have been partialy copied.

Answer:

unit copythread;

interface

uses
  Classes, SysUtils;

const
  KB1 = 1024;
  MB1 = 1024 * KB1;
  GB1 = 1024 * MB1;

type
  TCopyFile = class(TThread)
  public
    Percent: Integer;
    Done, ToDo: Integer;
    Start: TDateTime;
    constructor Create(Src, Dest: string);
  private
    { Private declarations }
    IName, OName: string;
  protected
    procedure Execute; override;
  end;

implementation

{ TCopyFile }

constructor TCopyFile.Create(Src, Dest: string);
begin
  IName := Src;
  OName := Dest;
  Percent := 0;
  Start := Now;
  FreeOnTerminate := True;
  inherited Create(True);
end;

procedure TCopyFile.Execute;
var
  fi, fo: TFileStream;
  dod, did: Integer;
  cnt, max: Integer;

begin

  Start := Now;
  try
    { Open existing destination }
    fo := TFileStream.Create(OName, fmOpenReadWrite);
    fo.Position := fo.size;
  except
    { otherwise Create destination }
    fo := TFileStream.Create(OName, fmCreate);
  end;
  try
    { open source }
    fi := TFileStream.Create(IName, fmOpenRead);
    try
      { synchronise dest en src }
      cnt := fo.Position;
      fi.Position := cnt;
      max := fi.Size;
      ToDo := Max - cnt;
      Done := 0;

      { start copying }
      repeat
        dod := MB1; // Block size
        if cnt + dod > max then
          dod := max - cnt;
        if dod > 0 then
          did := fo.CopyFrom(fi, dod);
        cnt := cnt + did;
        Percent := Round(Cnt / Max * 100);

        Done := Done + did;
        ToDo := Max;
      until (dod = 0) or (Terminated);

    finally
      fi.free;
    end;
  finally
    fo.free;
  end;
end;

end.

What is the difference between Borland DataSnap and Microsof ADO.NET

Problem/Question/Abstract:

What is the difference between Borland DataSnap and Microsof ADO.NET

Answer:

// Torry's Delphi Tips - Database
// Author Pablo Reyes
// Listed 04.10.2003
Borland DataSnap vs Microsof ADO.NET
====================================
Delphi 7 and .NET Framework 1.1
A comparison between the tools provided by these two technologies for
building data aware applications.

Data access technologies:
=========================
Everybody knows that Borland DataSnap provides four data access technologies.
While ADO.NET is a data access technology, it provides four embedded data access technologies.
Third party companies provide data access technologies for both.

*** Borland DataSnap ***
- Borland Database Engine (BDE)
- dbExpress (DBX)
- InterBase Express (IBX)
- Activex Data Objects (ADO)
- Third party

*** Microsoft ADO.NET ***
- SQL for MS SQL Server
- OleDb
- ODBC
- Oracle
- Third party

Provide/Resolve
===============
Both uses a provide/resolve mechanism. You first provide data to a
component which holds data in memory in a disconnected fashion.
Changes to this data are hold in memory too.
Then you apply this changes to the underlying database.
So what you need is...

Components to establish a connection:
-------------------------------------
This components let you establish a connection with a
database and manage transactions.

*** Borland DataSnap ***
- Session and Database
- SQLConnection
- IBDatabase and IBTransaction
- ADOConnection
- Third party

*** Microsoft ADO.NET ***
- SQLConnection
- OleDbConnection
- ODBCConnection
- OracleConnection
- Third party

Borland DataSnap connection components have many similarities
between them but they all are different. All Microsoft ADO.NET
connection components implements the same interface.

Components to obtain data:
--------------------------
This components let you obtain a data set form a database
through one of the connection components.

*** Borland DataSnap ***
- Table, Query, StoredProc
- SQLTable, SQLQuery, SQLStoredProc, SQLDataSet
- IBTable, IBQuery, IBStoredProc, IBDataSet
- ADOTable, ADOQuery, ADOStoredProc, ADODataSet
- Third party

*** Microsoft ADO.NET ***
- SQLCommand, SQLDataReader
- OleDbCommand, OleDbDataReader
- ODBCCommand, OleDbDataReader
- OracleCommand, OracleDataReader
- Third party

Borland DataSnap components used to obtain data have many similarities between
them but they all are different. All Microsoft ADO.NET components used to obtain
data implements the same interface.
While some of the Borland DataSnap components used to obtain data let you obtain
a read-write, bi-directional data sets, all Microsoft components used to obtain
data provide read-only, forward-only data sets.

Components to provide data and resolve changes:
-----------------------------------------------
This components do two main things: provide data and resolve changes.
While Borland DataSnap component can perform it in a connected and disconnected fashion,
Microsoft ADO.NET component can perform it only in a disconnected fashion.

*** Borland DataSnap ***
- DataSetProvider

Provide:
- Connect it to a DataSet and it provides data to a ClientDataSet.
The DataSet must implements IProviderSupport interface.
- If the connected DataSet is a master DataSet it recognize the
master/detail relationship and provide data treating master record
and its detail records as a unit.

Resolve:
- It generates SQL statements on the fly using information form the
connected DataSet, even if you use JOINs.
- It treats master and details as a unit and generates transactions
for updating master and details in the same transaction and updates
data in the correct order (for inserts, first master and then details;
for deletes, first details and then master).
- It lets you configure how SQL statement should be generated.
- It manages concurrency.

*** Microsoft ADO.NET ***
- DataAdapter

Provide:
- You use a DataAdapter to fill a DataSet with records.
It could use embedded Command components or it could be connected
to your Command components.
- DataAdapter does not recognize master/detail relationships.
You need to use one DataAdapter for each table.

Resolve:
- It generates SQL statements on the fly using information from the SELECT statement,
but only for single tables.
- You must use one DataAdapter for each table so it updates only one table.
- It does not let you configure how SQL statement should be generated.
- It manages concurrency.

Components to hold data and changes in memory:
----------------------------------------------
This components hold data and changes to that data in memory.
Both can save its data to a file on disk and resolve updates later.

*** Borland DataSnap ***
- ClientDataSet

- It is aware of the DataSetProvider so they work together to apply
updates and reconcile update errors.
- Details are an extra field of the master. If you modify details
you also modify the master.
- It provides functionality to obtain details and BLOBs on demand.

*** Microsoft ADO.NET ***
- DataSet

- It doesn't aware of the DataAdapter so they don't work synchronized
and it doesn't know about update errors.
- Has a collection of tables and relations between this tables.
If you modify details you don't modify the master.
- It doesn't provide functionality to obtain details and BLOBs on demand.

Conclusions
===========
Borland DataSnap is a mature technology while Microsoft ADO.NET is an emerging,
new technology with an excellent starting point. You can accomplish the same task
with both technologies but you need to code a lot more with Microsoft ADO.NET.
With DataSetProvider and ClientDataSet from Borland DataSnap you get more than
with DataAdapter and DataSet from Microsoft ADO.NET.

Pablo Reyes

Bitmap crossfade

Problem/Question/Abstract:

Well I have two pictures and I want to put the second on the first but with transparence. This could be usefull in many situations.

Answer:

The function combines two images in a crossfade image and returns it.

function returncross(srcbit, markbit: TBitmap; srcleft, srctop, markleft, marktop:
integer): TBitmap;
var
x, y: integer;
psrc, pmark: PByteArray;
begin
srcbit.PixelFormat := pf24bit;
markbit.PixelFormat := pf24bit;

for y := 0 to markbit.Height - 1 do
begin
if y + srctop psrc := srcbit.ScanLine[y + srctop];

pmark := markbit.ScanLine[y + marktop];

for x := 0 to srcbit.Width - 1 do
begin
if (y + srctop < srcbit.Height) and (x + srcleft < srcbit.Width) then
begin
psrc^[(x + srcleft) * 3] := (psrc^[(x + srcleft) * 3] + pmark^[(x + markleft)
* 3]) div 2;
psrc^[(x + srcleft) * 3 + 1] := (psrc^[(x + srcleft) * 3 + 1] + pmark^[(x +
markleft) * 3 + 1]) div 2;
psrc^[(x + srcleft) * 3 + 2] := (psrc^[(x + srcleft) * 3 + 2] + pmark^[(x +
markleft) * 3 + 2]) div 2;
end;
end;
end;

result := srcbit;
end;

srcbit - the first picture, on the foreground
markbit - the second picture, this picture is drawed transparently
srcleft - the left coordinate of the drawed markbit
srctop  - the top coordinate ...
markleft and marktop are used if you want to take only a part of the picture (by default you can use 0)

Usage example:

Put on a form two tpicture objects (image1, image2). Load some bitmaps in them. In a button click event you can place the next line.

image1.Picture.Bitmap := putwatermark(image1.Picture.Bitmap, image2.Picture.Bitmap, 0,
0, 0, 0);

How InteBase stores the passwords?

Problem/Question/Abstract:

How InteBase stores the passwords?

Answer:

InterBase stores all of it's user name information in a database called ISC4.gdb.
It is the "user" table that contains the "User_Name" and "Passwd" fields for each user.
To get a list of the valid user do a:
select user_name from users;

Just because a user is listed in the users table, doesn't mean that they have rights to access
any of the tables in InteBase. Access to each table is handled by sql grant and revokes and that data
is stored in the actual database not isc4.gdb.

The passwords for each user is stored in the passwd field and are encrypted.
The password is encrypted with the UNIX crypt routine (DES Salt).
That routine requires a salt which is always "9z". The resulting encrypted data
is striped of the "9z" (11 char. left) and crypted again with the same "9z" salt.
The result, once striped of the "9z" is the encrypted password as found in the ISC4.GDB database.

Load a JPG in a TImage, preserving the aspect ratio

Problem/Question/Abstract:

Load a JPG preservind the original aspect ratio of the JPG.

Answer:

procedure TForm1.Button1Click(Sender: TObject);

procedure CargaJPGProporcionado(Fichero: string;
const QueImage: TImage);
var
ElJPG: TJpegImage;
Rectangulo: TRect;

EscalaX,
EscalaY,
Escala: Single;

begin
ElJPG := TJPegImage.Create;

try

ElJPG.LoadFromFile(Fichero);

//Por defecto, escala 1:1
EscalaX := 1.0;
EscalaY := 1.0;

//Hallamos la escala de reducci�n Horizontal
if QueImage.Width < ElJPG.Width then
EscalaX := QueImage.Width / ElJPG.Width;

//La escala vertical
if QueImage.Height < ElJPG.Height then
EscalaY := QueImage.Height / ElJPG.Height;

//Escogemos la menor de las 2
if EscalaY < EscalaX then
Escala := EscalaY
else
Escala := EscalaX;

//Y la usamos para reducir el rectangulo destino
with Rectangulo do
begin
Right := Trunc(ElJPG.Width * Escala);
Bottom := Trunc(ElJPG.Height * Escala);
Left := 0;
Top := 0;
end;

//Dibujamos el bitmap con el nuevo tama?o en el TImage destino
with QueImage.Picture.Bitmap do
begin
Width := Rectangulo.Right;
Height := Rectangulo.Bottom;
Canvas.StretchDraw(Rectangulo, ElJPG);
end;

finally
ElJPG.Free;
end;

end; {De CargaJPGProporcionado}

begin
CargaJPGProporcionado('UnaFoto.jpg', Image1);
end;

Use a TPanel as a host for child windows (MDI simulation) (2)

Problem/Question/Abstract:

Does anyone know if it is possible to change the Parent of the Mainform's client window in such a way that MDI forms are correctly displayed within (for instance) a panel?

Answer:

Here is a class that we use to place forms in panels:

unit oSubForm;

interface

uses
  Forms, Controls;

type
  TSubForm = class(TForm)
  public
    procedure CreateParams(var Params: TCreateParams); override;
    { ... }
    function SetUp: boolean; virtual;
    function Activate: boolean; virtual;
    function Deactivate: boolean; virtual;
    function Validate: boolean; virtual;
    function AddKnockOnChanged(Sender: TObject): boolean; virtual;
    { ... }
    procedure SetAllChanged; virtual;
  end;

type
  TDfEE_Form = class(TForm)
  private
  protected
  public
    function PageValidate(nPage: integer): boolean; virtual;
  published
  end;

implementation

uses
  WinTypes;

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    WndParent := TWinControl(Owner).Handle;
    Params.Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
  end;
  Align := alClient;
  Parent := TWinControl(Owner);
end;

function TSubForm.SetUp: boolean;
begin
end;

function TSubForm.Activate: boolean;
begin
end;

function TSubForm.Deactivate: boolean;
begin
end;

procedure TSubForm.SetAllChanged;
begin
end;

function TSubForm.Validate: boolean;
begin
end;

function TSubForm.AddKnockOnChanged(Sender: TObject): boolean;
begin
end;

function TDfEE_Form.PageValidate(nPage: integer): boolean;
begin
  result := True;
end;

end.

Read the properties of a Word document

Problem/Question/Abstract:

I want to read the properties of a MS Word document (the title). I use the function builtInDocumentProperties, but it returns a IDispatch Interface and I don't know how to get the value. If I write Document.BuiltInProperties[wdPropertyTitle].Value, I get an error.

Answer:

Variants are the easiest way of dealing with these properties.

{ ... }
var
  Doc: OleVariant;
  { ... }
  Doc := Word.ActiveDocument;
  Doc.BuiltInDocumentProperties['Title'].Value := 'The title';
  Doc.BuiltInDocumentProperties['Category'].Value := 'Category';
  { ... }

How to fire the OnTitleClick event of a TDBGrid and discard the OnDblClick event at the same time

Problem/Question/Abstract:

How do I know if the user has double-clicked the titlebar or anywhere else on a DBGrid? I have a project that responds to both the OnTitleClick and the OnDblClick of the grid. Unfortunately if a user decides to double click on the title bar both events end up firing and that's not good. Any way to get the title bar OnTitleClick to fire and discard the double click? Or can I simply tell that it's pointing over the title bar?

Answer:

procedure TForm1.DBGrid1DblClick(Sender: TObject);
var
  CurPos: TPoint;
begin
  CurPos := DBGrid1.ScreenToClient(Mouse.CursorPos);
  if (DBGrid1.MouseCoord(CurPos.X, CurPos.Y)).Y = 0 then
    DBGrid1.Tag := 1;
end;

procedure TForm1.DBGrid1TitleClick(Column: TColumn);
begin
  if DBGrid1.Tag = 0 then
    beep;
  DBGrid1.Tag := 0;
end;

InterBase: "lock manager out of room"

Problem/Question/Abstract:

My application that runs against InterBase 5 throws an exception "sql code -104, lock manager out of room". How can I increase the lock space?

Answer:

Go to the interbase/bin directory (Windows) or /usr/interbase (Unix) and locate the configuration file isc_config. By default your configuration file will look like this:

#V4_LOCK_MEM_SIZE�������                98304
#ANY_LOCK_MEM_SIZE������        98304
#V4_LOCK_SEM_COUNT������        32
#ANY_LOCK_SEM_COUNT����32
#V4_LOCK_SIGNAL��������                16
#ANY_LOCK_SIGNAL��������                16
#V4_EVENT_MEM_SIZE������        32768
#ANY_EVENT_MEM_SIZE�����        32768

I increased the V4_LOCK_MEM_SIZE entry from 98304 to 198304 and things were fine then.

!!! Important !!!

By default all lines in the config file are commented out with the leading # sign. Make sure to remove the # sign in any line that you change - the default config file just shows the default parameters.

Karp-Rabin string searching

Problem/Question/Abstract:

Karp-Rabin string searching

Answer:

Do you need a fast routine that searches a string within a string? Try the Karp-Rabin algorithm:


function search(pat: PATTERN; Text: Text): integer;
const
  b = 131;
var
  hpat, htext, Bm, j, m, n: integer;
  found: Boolean;
begin
  found := False;
  search := 0;
  m := length(pat);
  if m = 0 then
  begin
    search := 1;
    found := true
  end;

  Bm := 1;
  hpat := 0;
  htext := 0;
  n := length(Text);
  if n >= m then
    {*** preprocessing ***}
    for j := 1 to m do
    begin
      Bm := Bm * b;
      hpat := hpat * b + ord(pat[j]);
      htext := htext * b + ord(Text[j])
    end;

  j := m;
  {*** search ***}
  while not found do
  begin
    if (hpat = htext) and (pat = substr(Text, j - m + 1, m)) then
    begin
      search := j - m + 1;
      found := true
    end;
    if j < n then
    begin
      j := j + 1;
      htext := htext * b - ord(Text[j - m]) * Bm + ord(Text[j])
    end
    else
      found := true
  end
end;

How to detect if a TreeView has a scrollbar and how to change its position?

Problem/Question/Abstract:

How to detect if a TreeView has a scrollbar?
How to change the scrollbar in a TreeView (if it has one)?

Answer:

procedure TForm1.FormMouseWheelDown(Sender: TObject;
  Shift: TShiftState;
  MousePos: TPoint;
  var Handled: Boolean);

var
  iMin, iMax: Integer;
  bTreeViewVertScrollBarVisible: Boolean;

begin
  bTreeViewVertScrollBarVisible := True;
  GetScrollRange(Form1.TreeView1.Handle, SB_VERT, iMin, iMax);
  if iMin = iMax then
    bTreeViewVertScrollBarVisible := False; // No scrollbar visible

  if bTreeViewVertScrollBarVisible then
  begin
    iPos := GetScrollPos(Form1.TreeView1.Handle, SB_VERT);
    SetScrollPos(Form1.TreeView1.Handle, SB_VERT, iPos + 1, True);
    // Don't set Handled to True!
    // If you do that then ONLY the scrollbar changes but NOT the
    // content of the TreeView!
  end;

end;

How do I make transparent forms?

Problem/Question/Abstract:

How do I make transparent forms?

Answer:

You need to override the CreateParam function and there add WS_EX_TRANSPARENT
to the Params.ExStyle.

Set the form's canvas' Brush.Style to bsClear, as shown in this example:

type
  TMyForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TMyForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  // this is the important constant!
  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TMyForm.FormCreate(Sender: TObject);
begin
  inherited;
  Canvas.Brush.Style := bsClear;
end;

Control the AutoPlay feature

Problem/Question/Abstract:

Control the AutoPlay feature

Answer:

You know how to stop Windows' [CD-ROM] AutoPlay from occurring by holding SHIFT or by changing Windows settings.

Here's how to detect whether an AutoPlay is about to occur from your application and then either allowing or stopping it.

We're going to ask Windows to send us a message when the AutoPlay is about to occur. In order to catch this message, first of all we have to override our default Windows message handler -- "WndProc()."

You can do this by inserting the following code in your form's (named "Form1" for example) public declarations section:


MsgID_QueryCancelAutoPlay: Word;

procedure WndProc(var Msg: TMessage); override;


Now, type in the following code in the "implementation" section (again, assuming that your form is named "Form1") to actually handle the Windows messages. As you can see, we're only interested in catching "QueryCancelAutoPlay" messages, so we'll let the default (or the inherited) "WndProc()" handle all other messages.


procedure TForm1.WndProc(var Msg: TMessage);
begin
  if Msg.Msg = MsgID_QueryCancelAutoPlay then
  begin
    { set Msg.Result
       to 1 to stop AutoPlay or
       to 0 to continue with AutoPlay }
    Msg.Result := 1;
  end
  else
    inherited WndProc(Msg);
end;


Finally, we have to ask Windows to actually send a "QueryCancelAutoPlay" message to our message handler by inserting the following code in the "FormCreate()" event (click on your form, go to the "events" tab in the "Object Inspector" and double click on "Create"):


MsgID_QueryCancelAutoPlay := RegisterWindowMessage('QueryCancelAutoPlay');

How to create transparent bitmaps

Problem/Question/Abstract:

What I'd like to see is an image component which can be positioned over other windows/ images and use their respective canvases to fill-in its transparent color. My question is, does this component use as its background the bitmap of the window(s)/ device context(s) which it covers?

Answer:

Here's an excerpt of code that draws a transparent bitmap. I still use a mask, but the program does it for me. And, yes it is easy to draw over other graphic controls, all you need to do is to grab the form's canvas before drawing.


{ ... }
if (FTmpComp.Transparent) and (FTmpComp.CellMask.Width = 0) then
  {need to draw w/out cellmask}
try
  {Setup temp bitmaps}
  TmpBitmap := TBitmap.Create;
  TmpBitmap.Height := FTmpComp.Height;
  TmpBitmap.Width := FTmpComp.Width;
  MskBitmap := TBitmap.Create;
  MskBitmap.Height := FTmpComp.Height;
  MskBitmap.Width := FTmpComp.Width;
  MskBitmap.Monochrome := True;
  ImgBitmap := TBitmap.Create;
  ImgBitmap.Height := FTmpComp.Height;
  ImgBitmap.Width := FTmpComp.Width;
  {Create Mask}
  MskBitmap.Canvas.Brush.Color := clWhite;
  MskBitmap.Canvas.BrushCopy(DRect, FTmpComp.CellPicture, SRect,
    FTmpComp.CellPicture.Canvas.Pixels[0, 0]);
  MskBitmap.Canvas.CopyMode := cmSrcInvert;
  MskBitmap.Canvas.CopyRect(DRect, FTmpComp.CellPicture.Canvas, SRect);
  {Create 'blacked out' image}
  ImgBitmap.Canvas.CopyMode := cmNotSrcCopy;
  ImgBitmap.Canvas.CopyRect(Drect, MskBitmap.Canvas, DRect);
  ImgBitmap.Canvas.CopyMode := cmSrcAnd;
  ImgBitmap.Canvas.CopyRect(DRect, FTmpComp.CellPicture.Canvas, SRect);
  {Copy background from FPicture into the temp bitmap}
  TmpBitmap.Canvas.CopyMode := cmSrcCopy;
  TmpBitmap.Canvas.CopyRect(DRect, FPicture.Canvas, FRect);
  {AND the mask into the background to provide 'cut-out'}
  TmpBitmap.Canvas.CopyMode := cmSrcAnd;
  TmpBitmap.Canvas.CopyRect(DRect, MskBitmap.Canvas, DRect);
  {PAINT the CellPicture into the hole}
  TmpBitmap.Canvas.CopyMode := cmSrcPaint;
  TmpBitmap.Canvas.CopyRect(DRect, ImgBitmap.Canvas, DRect);
  {finally copy the temp bitmap onto the main canvas}
  Canvas.CopyMode := cmSrcCopy;
  Canvas.CopyRect(FRect, TmpBitmap.Canvas, DRect);
  {mark the Cell as having been updated}
  FTmpComp.IsDirty := False;
finally
  {free the bitmaps}
  TmpBitmap.Free;
  MskBitmap.Free;
  ImgBitmap.Free;
end;

How to use TStrings.DelimitedText to separate a comma delimited string

Problem/Question/Abstract:

I am trying to use TStrings.DelimitedText to separate a comma delimited string. The trouble is (some of my strings contain spaces, for example a person's address), with TStrings.DelimitedText it seems to have the space character set as a delimiter as well as the character that I specify. How do I stop it from doing this?

Answer:

The substrings in the comma-separated list have to be enclosed in the TStrings.QuoteChar for this to work properly. The way TStrings.SetDelimitedText has been written it will not only break on the Delimiter character but also on any character in the range #1..' ' when they appear outside a quoted string. The SplitString routine below does not suffer from this problem but it does not handle delimiters inside quoted strings.

{Function IScan
Parameters:
ch: Character to scan for
S : String to scan
fromPos: first character to scan
Returns: position of next occurence of character ch, or 0, if none found
Description: Search for next occurence of a character in a string.
Error Conditions: none
Created: 11/27/96 by P. Below}

function IScan(ch: Char; const S: string; fromPos: Integer): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := fromPos to Length(S) do
  begin
    if S[i] = ch then
    begin
      Result := i;
      Break;
    end;
  end;
end;

{Procedure SplitString
Parameters:
S: String to split
separator: character to use as separator between substrings
substrings: list to take the substrings
Description:
Isolates the individual substrings and copies them into the passed stringlist. Note that we only add to the list, we do not clear it first! If two separators follow each other directly an empty string will be added to the list.
Error Conditions:
will do nothing if the stringlist is not assigned
Created: 08.07.97 by P. Below}

procedure SplitString(const S: string; separator: Char; substrings: TStringList);
var
  i, n: Integer;
begin
  if Assigned(substrings) and (Length(S) > 0) then
  begin
    i := 1;
    repeat
      n := IScan(separator, S, i);
      if n = 0 then
        n := Length(S) + 1;
      substrings.Add(Copy(S, i, n - i));
      i := n + 1;
    until
      i > Length(S);
  end;
end;

How to count words in a TRichEdit

Problem/Question/Abstract:

How to count words in a TRichEdit

Answer:

function GetWord: boolean;
var
  s: string; {presume no word > 255 chars}
  c: char;
begin
  result := false;
  s := ' ';
  while not EOF(f) do
  begin
    read(f, c);
    if not (c in ['a'..'z', 'A'..'Z' {,... etc.}]) then
      break;
    s := s + c;
  end;
  result := (s <> ' ');
end;

procedure GetWordCount(TextFile: string);
begin
  Count := 0;
  assignfile(f, TextFile);
  reset(f);
  while not EOF(f) do
    if GetWord then
      inc(Count);
  closefile(f);
end;

How to implement an OnMouseDown event for the buttons of a TRadioGroup

Problem/Question/Abstract:

I have created a decendant of TRadioGroup called TSuperRadioGroup. With this new control, I have surfaced the onmousedown event. But the event is only triggered when the mouse goes down on the border or caption of the Group, not the Radio Buttons themselves.

Answer:

The solution I use is to register a window procedure for the radiobuttons. You can trap the Windows messages there.

procedure TSuperRadioGroup.RegisterWndProc;
var
  BtnHnd: hWnd;
  ItrBtn: Integer;
begin
  inherited;
  HasWndProc := True;
  BtnHnd := GetWindow(Handle, GW_CHILD);
  ItrBtn := 0;
  while BtnHnd > 0 do
  begin
    if GetWindowLong(BtnHnd, GWL_USERDATA) <> 0 then
      raise Exception.Create('Userdata may not be used');
    ButtonHandle[ItrBtn] := BtnHnd;
    OrigWndProc[ItrBtn] := GetWindowLong(BtnHnd, GWL_WNDPROC);
    SetWindowLong(BtnHnd, GWL_USERDATA, Longint(self));
    SetWindowLong(BtnHnd, GWL_WNDPROC, Longint(@RadioBtnWndProc));
    Inc(ItrBtn);
    BtnHnd := GetWindow(BtnHnd, GW_HWNDNEXT);
  end;
end;

In the RadioBtnWndProc window procedure you can use this code to get at the radiogroup object and the specific button:

Obj := TObject(GetWindowLong(WndHnd, GWL_USERDATA));
if Obj is TSuperRadioGroup then
begin
  RadioGrp := TSuperRadioGroup(Obj);
  for ItrBtn := 0 to RadioGrp.Items.Count - 1 do
  begin
    if WndHnd = RadioGrp.ButtonHandle[ItrBtn] then
    begin
      OrigWndProc := RadioGrp.OrigWndProc[ItrBtn];
      break;
    end;
  end;
end;

If the message is not completely handled, you need to call the original wndproc at the end of your specialized wndproc:

Result := CallWindowProc(Pointer(OrigWndProc), WndHnd, Msg, WParam, LParam);

How to check the timer progress

Problem/Question/Abstract:

I have a TTimer that is programmed to show a message box after 5 minutes. Is there a way to check how much of the timer interval has passed after a certain time?

Answer:

You will have to use a timer that occurs every second and increments a variable (even its own Tag property).

TForm1.Timer1Timer(Sender: ...);
begin
  Timer1.tag := Timer1.tag + 1;
  if Timer1.tag = 300 then
  begin
    Timer1.enabled := false;
    {If you leave, it will show a message every 5 minutes, resulting in many windows;
    suspend counting for the period showing the message}
    Timer1.tag := 0;
    showmessage('5 Minutes!!!');
    Timer1.enabled := true;
  end;
end;

TForm1.button1click(....);
begin
  showmessage('Only ' + inttostr(Timer1.tag div 60) + ' minutes and ' +
    inttostr(Timer1.tag mod 60) + ' seconds have passed');
end;

Working with delphi menus

Problem/Question/Abstract:

How to hack delphi environment (IDE)?

Answer:

This is just a sample application for interacting with Delphi IDE.U can use it more extensively. For invoking other applications u just need to change the menuclick event handler.

Given below is the full code. Compile this unit into a package and install the same.

unit SubhaExp;

interface

uses Windows, Menus, ExtCtrls, SysUtils, Forms, ToolsApi;

type
  TSubhaMenu = class

  private
    FMainMenu: TMainMenu;
    FFileMenu: TMenuItem;
    FGiriMenu: TMenuItem;
    procedure OnMenuItemClick(Sender: TObject);

  public
    procedure AddMenuItem;
    procedure RemoveMenuItem;

  end;

var
  FSubhaMenu: TSubhaMenu;

procedure Register;

implementation

procedure TSubhaMenu.AddMenuItem;
var
  i: Integer;
begin

  FMainMenu := (BorlandIDEServices as INTAServices).MainMenu;
  for i := 0 to FMainMenu.Items.Count - 1 do
  begin
    if AnsiSameCaption(FmainMenu.items[i].Caption, 'File') then
    begin
      FFileMenu := FMainMenu.items[i];
      Break;
    end;
  end;

  FGiriMenu := TMenuItem.Create(FFileMenu);
  FGiriMenu.Caption := 'Subha IDE Services';
  FGiriMenu.OnClick := OnMenuItemClick;

  for i := 0 to FFileMenu.count - 1 do
  begin
    if FFileMenu.Items[i].isLine then
    begin
      FFileMenu.Insert(i, FGiriMenu);
      Break;
    end;
  end;

end;

procedure TSubhaMenu.RemoveMenuItem;
var
  i: Integer;
begin
  for i := 0 to FFileMenu.Count - 1 do
  begin
    if AnsiSameCaption(FFileMenu.Items[i].Caption, 'Subha IDE Services') then
    begin
      FFileMenu.Remove(FFileMenu.items[i]);
      Break;
    end;
  end;
end;

procedure TSubhaMenu.OnMenuItemClick(Sender: TObject);
begin
  Application.MessageBox(PChar('This Is only a Simple Example' +
    ' to Work With Delphi IDE ' + #13#10 + ' For Further Details On This Contact' +
    #13#10#13#10 + ' Subha@botree.co.in'), PChar('Message From Subha'), MB_OK);
end;

procedure Register;
begin
  FSubhaMenu.AddMenuItem;
  Application.MessageBox('Subha Narayanan Has Hacked Your ' +
    ' Delphi Environment !!! ' + #13#10 +
    ' See You Soon With Lot More Goodies !!! ' +
    #13#10 + ' CopyRight (c) 2001, Subha Narayanan. ',
    ' Welcome To Delphi ', MB_SYSTEMMODAL);
end;

initialization
  FSubhaMenu := TSubhaMenu.Create;

finalization
  FSubhaMenu.RemoveMenuItem;
  FSubhaMenu.Free;

end.