How to pop up a TComboBox at the current caret position in a TMemo

Problem/Question/Abstract:

I would like to pop up a TComboBox at the caret position on a TMemo when the key that is pressed is a full stop (.). Has anyone got any code for this?

Answer:

unit CBoxInMemo;

interface

uses
  Windows, Classes, Controls, Graphics, Forms, StdCtrls;

type
  TFrmCboxInMemo = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Label1: TLabel;
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure ComboBox1Exit(Sender: TObject);
    procedure ComboBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmCboxInMemo: TFrmCboxInMemo;

implementation

{$R *.DFM}

procedure TFrmCboxInMemo.Button1Click(Sender: TObject);
var
  clientPos: TPoint;
  lineHeight: Integer;
  tmpFont: TFont;
begin
  GetCaretPos(clientPos);
  {Use the following calculation of line height only if you want your combobox
  to appear below the char position you are referencing.}
  tmpFont := Canvas.Font;
  Canvas.Font := Memo1.Font;
  lineHeight := Canvas.TextHeight('Xy');
  Canvas.Font := tmpFont;
  with ComboBox1 do
  begin
    {Adjustment of Top by lineHeight only necessary if combobox is to appear below line.}
    Top := clientPos.Y + Memo1.Top + lineHeight;
    Left := clientPos.X + Memo1.Left;
    Visible := true;
    SetFocus;
  end;
end;

procedure TFrmCboxInMemo.ComboBox1Exit(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

procedure TFrmCboxInMemo.ComboBox1Click(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

end.

Use a lowpass filter to blur images

Problem/Question/Abstract:

Does anyone know of a (preferably online) source of information for blurring algorithms? I'm looking for a simple way of blurring an image.

Answer:

A lowpass filter does the job. Copy the image to memory. Then take a zeroed piece of memory the same size. Pull a 3x3 window over your memory image (for x, for y) within this window, multiply the underlying pixels with the constant window multiplyer :

1 1 1 //
1 1 1
1 1 1

and add them up. This value/9 assign to the new memory image at (x,y).

{ ... }
for x := 0 to image1.width - 1 do
begin
  for y := 0 to image1.height - 1 do
  begin
    s := 0;
    for h := -1 to 1 do
    begin
      for v := -1 to 1 do
      begin
        s := s + memimage[x + h, y + v];
      end;
    end;
    new_memimage[x, y] := s / 9;
  end;
end;
{ ... }

then copy the new memory image to the image. Note that the border of the image has to be treated specially. (array range)

How to view dBase records which are marked for deletion

Problem/Question/Abstract:

How to view dBase records which are marked for deletion

Answer:

Call the following function on the AfterOpen event of the table. You must include DBITYPES, DBIERRS, DBIPROCS in the uses clause. To call, send as arguments name of TTable and True / False depending to show / not show deleted records. Example:

procedure TForm1.Table1AfterOpen(DataSet: TDataset);
begin
  SetDelete(Table1, TRUE);
end;

procedure SetDelete(oTable: TTable; Value: Boolean);
var
  rslt: DBIResult;
  szErrMsg: DBIMSG;
begin
  try
    oTable.DisableControls;
    try
      rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,
        LongInt(Value));
      if rslt <> DBIERR_NONE then
      begin
        DbiGetErrorString(rslt, szErrMsg);
        raise Exception.Create(StrPas(szErrMsg));
      end;
    except
      on E: EDBEngineError do
        ShowMessage(E.Message);
      on E: Exception do
        ShowMessage(E.Message);
    end;
  finally
    oTable.Refresh;
    oTable.EnableControls;
  end;
end;

Swap columns in a TStringGrid

Problem/Question/Abstract:

Does anyone know how to swap two columns in TStringGrid? If you try to exchange() the two columns as if they are TStringLists all hell breaks out (... because they aren't really TStringLists I guess?).

Answer:

I would use an intermediate, temporary string list. Let's say you want to exchange columns 3 and 5:

var
  Temp: TStringList;
begin
  Temp := TStringList.Create;
  Temp.Assign(MyGrid.Cols[3]);
  MyGrid.Cols[3].Assign(MyGrid.Cols[5]);
  MyGrid.Cols[5].Assign(Temp);
  Temp.Free;
end;

How to detect the Windows OS version

Problem/Question/Abstract:

How to detect the Windows OS version

Answer:

Solve 1:

uses
  Windows;

type
  TWinVersion = (Win32, Win9x, WinNt, WinError);

function fWinVersion: TWinVersion;
var
  GV: TOSVersionInfo;
begin
  GV.dwOSVersionInfoSize := Sizeof(GV);
  if GetVersionEx(GV) then
  begin
    case GV.dwPlatformId of
      VER_PLATFORM_WIN32s:
        Result := Win32;
      VER_PLATFORM_WIN32_WINDOWS:
        Result := Win9x;
      VER_PLATFORM_WIN32_NT:
        Result := WinNT;
    else
      Result := WinError;
    end;
  end
  else
    Result := WinError;
end;


Solve 2:

type
  PTransBuffer = ^TTransBuffer;
  TTransBuffer = array[1..4] of smallint;

const
  CInfoStr: array[1..4] of string = ('FileVersion', 'LegalCopyright', 'ProductName',
    'ProductVersion');

procedure TFrmAbout.GetVersionInfo(AVersionList: TStrings);
var
  filename: string;
  i: integer;
  infoSize: DWORD;
  ptrans: PTransBuffer;
  transStr: string;
  typeStr: string;
  value: PChar;
  verBuf: pointer;
  verSize: DWORD;
  wnd: DWORD;
begin
  AVersionList.Clear;
  filename := Application.ExeName;
  infoSize := GetFileVersioninfoSize(PChar(filename), wnd);
  if infoSize <> 0 then
  begin
    GetMem(verBuf, infoSize);
    try
      if GetFileVersionInfo(PChar(filename), wnd, infoSize, verBuf) then
      begin
        VerQueryvalue(verBuf, PChar('\VarFileInfo\Translation'), Pointer(ptrans),
          verSize);
        transStr := IntToHex(ptrans^[1], 4) + IntToHex(ptrans^[2], 4);
        for i := Low(CInfoStr) to High(CInfoStr) do
        begin
          typeStr := 'StringFileInfo\' + transStr + '\' + CInfoStr[i];
          if VerQueryvalue(verBuf, PChar(typeStr), Pointer(value), verSize) then
            {AVersionList.Add(CInfoStr[i] + ': ' + value);}
            AVersionList.Add(value);
        end
      end;
    finally
      FreeMem(verBuf);
    end;
  end;
end;


Solve 3:

Delphi 5 has a variable Win32Platform in SysUtils

var
  Win32Platform: Integer = 0;

It will have 3 values

VER_PLATFORM_32s
VER_PLATFORM_WIN32_WINDOWS
VER_PLATFORM_WIN32_WIN_NT


Solve 4:

{ ... }
case Win32MajorVersion of
  3: {NT 3.51}
    OSLabel.Caption := 'Windows NT 3.51';
  4: {WIn9x/ME, NT 4}
    case Win32MinorVersion of
      0:
        OSLabel.Caption := 'Windows 95';
      10:
        OSLabel.Caption := 'Windows 98';
      90:
        OSLabel.Caption := 'Windows ME';
    else
      if (Win32Platform and VER_PLATFORM_WIN32_NT) <> 0 then
        OSLabel.Caption := 'Windows NT 4.0'
      else
        OSLabel.Caption := 'unknown';
    end;
  5: {Win2K, XP}
    case Win32MinorVersion of
      0:
        OSLabel.Caption := 'Windows 2000';
      1:
        OSLabel.Caption := 'Windows XP or .NET server';
    else
      OSLabel.Caption := 'unknown';
    end;
else
  OSLabel.Caption := 'unknown';
end;


Solve 5:

function GetOSInfo: string;
var
  Platform: string;
  BuildNumber: integer;
begin
  case Win32MajorVersion of
    3: {NT 3.51}
      Platform := 'Windows NT 3.51';
    4: {Win9x/ ME/ NT 4}
      case Win32MinorVersion of
        0:
          Platform := 'Windows 95';
        10:
          Platform := 'Windows 98';
        90:
          Platform := 'Windows ME';
      else
        if (Win32Platform and VER_PLATFORM_WIN32_NT) <> 0 then
          Platform := 'Windows NT 4.0'
        else
          Platform := SUnknown;
      end;
    5: {Win2000/ XP}
      case Win32MinorVersion of
        0:
          Platform := 'Windows 2000';
        1:
          Platform := 'Windows XP or .NET server';
      else
        Platform := SUnknown;
      end;
  else
    Platform := SUnknown;
  end;
  case Win32Platform of
    VER_PLATFORM_WIN32_WINDOWS:
      BuildNumber := Win32BuildNumber and $0000FFFF;
    VER_PLATFORM_WIN32_NT:
      BuildNumber := Win32BuildNumber;
  else
    BuildNumber := 0;
  end;
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or
    (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    if Win32CSDVersion = '' then
      Result := Format('%s (Build %d)', [Platform, BuildNumber])
    else
      Result := Format('%s (Build %d: %s)', [Platform, BuildNumber, Win32CSDVersion]);
  end
  else
    Result := Platform;
end;

Adding new methods and properties without registering new components

Problem/Question/Abstract:

Is there a way to add new methods and properties to a component without having its soruce code and having to install a descendant component?

Answer:

Adding new methods and properties

Sometimes we need to add new methods and properties to an existing component (or change the visibility of existing properties). One way of doing this is modifiying the component, but this implies having to recompile its package and we would have to redistribute our changes if we wanted our application to be compiled by others, and that would
be a bother for the recipients. Sometimes we may not even have that choice because we may not have the source code. In these situations, better would be to subclass (derive) the component and add new properties and methods. For example:

type
  TEditX = class(TEdit)
  public
    function GetForeColor: TColor;
    procedure SetForeColor(color: TColor);
    property ForeColor: TColor read GetForeColor write SetForeColor;
  end;

These methods could for example be implemented this way:

function TEditX.GetForeColor: TColor;
begin
  Result := Font.Color;
end;

procedure TEditX.SetForeColor(color: TColor);
begin
  Font.Color := Color;
end;

It's a silly example, of course, but it serves the purpose.

Casting to the new class

We don't need to intall this new component and register it in the components palette or replace existing controls in our applications (which would be an unpayable penalty for such small changes and/or additions). Instead, any time we want to access the new properties and methods, we can just cast the object (for example Edit1) to our new class. For example:

TEditX(Edit1).ForeColor := clRed;

or

TEditX(Edit1).SetForeColor(clRed);

Warning: This casting to a descendant class can only be done if the new class adds new properties and static methods, but without adding new fields and new virtual or dynamic methods, although in theory you can override existing virtual methods. Also, the visibility of existing properties can be changed, as in the InplaceEditor example
explained in the article "Accessing hidden properties".

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

Using UDL files to simplify ADO

Problem/Question/Abstract:

How do I get the ADO connection dialog up in Delphi

Answer:

Recently I had to do some work with SQL Server 7 using D4. To minimise the need for ODBC configuration, I chose to use ADO. As D4 lacks the Adoconed unit for displaying the ADO configuration dialogs, I found another way. If the UDL file is absent or corrupted, it displays the dialog then creates a new file. If however an existing configuration file is there then it loads it in and uses it.

For the ADO proper (which I haven&#8217;t shown- this just sets up the Ado connection string) I used the Ado components from http://www.alohaoi.com which are freeware with source and the best I&#8217;ve found.

Just install the Ado components then put a button on the form to test this below.

For anyone that is interested, the Msdasc objects (which manage the connection dialogs) are contained in oledb32.dll- import the type library to get access to this.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, aoADODB_tlb, aomsdasc_tlb, aoADODB, ComObj;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedure loadudl;
    procedure NewLink;
    { Private declarations }
  public
    ObjDataLink: Datalinks;
    dbConnection: connection;
    DataInitialize: IDataInitialize;
    WUdlFile: Widestring;
    AdoStr: string;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

const
  UdlFile = 'Adolink.udl';

procedure Tform1.loadudl;
var
  pwstr: pwidechar;
  wUDLFile: array[0..MAX_PATH - 1] of WideChar;
begin
  DataInitialize := CreateComObject(CLASS_DataLinks) as IDataInitialize;
  StringToWideChar(UDLFile, @wUDLFile, MAX_PATH);
  if Failed(DataInitialize.LoadStringFromStorage(wUDLFile, pwstr)) then
  begin
    ShowMessage('Link file corrupted or missing- please renew');
    Newlink;
  end
  else
  begin
    adostr := pwstr;
  end;
end;

procedure Tform1.NewLink;
var
  str: widestring;
  wUDLFile: array[0..MAX_PATH - 1] of WideChar;
begin
  str := '';
  ObjDataLink := Codatalinks.Create;
  if adostr <> '' then
  begin
    dbconnection := coconnection.create;
    dbconnection.ConnectionString := adostr;
    if ObjDataLink.PromptEdit(idispatch(dbconnection)) then
      str := dbconnection.ConnectionString;
  end
  else
  begin
    dbconnection := ObjDataLink.PromptNew as _connection;
    if assigned(dbconnection) then
      str := dbconnection.ConnectionString;
  end;
  DataInitialize := CreateComObject(CLASS_DataLinks) as IDataInitialize;
  StringToWideChar(UDLFile, @wUDLFile, MAX_PATH);
  sysutils.DeleteFile(udlfile);
  if Failed(DataInitialize.WriteStringToStorage(wUDLFile, pwidechar(Str), CREATE_NEW))
    then
    raise Exception.Create('Can''t write UDL to ' + udlfile);
  adostr := str;
end;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadUdl;
end;

end.

Creating two horizontal lines on your screen? (TDesktopCanvas)

Problem/Question/Abstract:

How do I create lines (or whatever) on the screen?

Answer:

This program demonstrates a TDesktopCanvas. I wrote this to prepare my self for using Trinitron monitors :)  The code parts are gathered from different parts of the www.

program TrinitronTraining;

uses
  Messages, Windows, Graphics, Forms;

type
  TDesktopCanvas = class(TCanvas)
  private
    DC: hDC;
    function GetWidth: Integer;
    function GetHeight: Integer;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
  end;

  { TDesktopCanvas object }

function TDesktopCanvas.GetWidth: Integer;
begin
  Result := GetDeviceCaps(Handle, HORZRES);
end;

function TDesktopCanvas.GetHeight: Integer;
begin
  Result := GetDeviceCaps(Handle, VERTRES);
end;

constructor TDesktopCanvas.Create;
begin
  inherited Create;
  DC := GetDC(0);
  Handle := DC;
end;

destructor TDesktopCanvas.Destroy;
begin
  Handle := 0;
  ReleaseDC(0, DC);
  inherited Destroy;
end;

const
  YCount = 2;

var
  desktop: TDesktopCanvas;
  dx, dy: Integer;
  i: Integer;
  F: array[1..YCount] of TForm;

function CreateLine(Y: Integer): TForm;
begin
  Result := TForm.Create(Application);
  with Result do
  begin
    Left := 0;
    Top := y;
    Width := dx;
    Height := 1;
    BorderStyle := bsNone;
    FormStyle := fsStayOnTop;
    Visible := True;
  end;
end;

procedure ProcessMessage;
var
  Msg: TMsg;
begin
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
    if Msg.Message = WM_QUIT then
      Application.Terminate;
end;

begin
  desktop := TDesktopCanvas.Create;
  try
    dx := desktop.Width;
    dy := desktop.Height div (YCount + 1);
  finally
    desktop.free;
  end;
  for i := 1 to YCount do
    F[i] := CreateLine(i * dy);
  Application.NormalizeTopMosts;
  ShowWindow(Application.Handle, SW_Hide);

  for i := 1 to YCount do
    SetWindowPos(F[i].Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE + SWP_NOMOVE +
      SWP_NOSIZE);

  { use this if you don't want to stop
    repeat
      ProcessMessage;
    until false;
  {}
  Sleep(15000);

  for i := 1 to YCount do
    F[i].Free;
end.

An ADO replacement for SQL Explorer

Problem/Question/Abstract:

Most programmers use the SQL Explorer which is installed by default with Delphi. With the announced extinction of the BDE, an alternative is needed for everyday&#8217;s common tasks. This is my solution.

How do I query an Access MDB File with ADO (no BDE installed)?

Answer:

The SQL Explorer has been for years one of the most important tools I used.
Now that I decided to shift from BDE solutions to ADO, I needed an alternative for the SQL Explorer which could gave me at least the same functionalities, so I created this little Delphi project (which I called ADO Explorer) which gaves me the main features a real programmer needs. In the next weeks I will prepare a second article in which I will explain how to customize and empower this program, makin it even a better solution that the Old, original, beloved SQL Explorer.

1. Open your Delphi 5 and create a new blank project.

2. On the form, drop these components:

An ADOConnection
An ADOQuery
A DBGrid
A DataSource
3 Buttons
A Memo component
An Edit component
An OpenDialog and SaveDialog component

3. Connect together the DB components (ADOConnection->ADOQuery->DataSource->DBGrid)

4. Insert in the first button&#8217;s OnClick Event handler this code:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ADOQuery1.Active then
    ADOQuery1.Close;
  if ADOConnection1.Connected then
    ADOConnection1.Connected := False;
  ADOConnection1.ConnectionString := Edit1.Text;
  ADOQuery1.SQL := Memo1.Lines;
  if UpperCase(Copy(Memo1.Lines[0], 1, 6)) = 'SELECT' then
  begin
    ADOQuery1.Open; // Result Set attended fro mthe operation
  end
  else
  begin
    ADOQuery1.ExecSQL; // No result set -> different method to open
  end;
end;

5. Insert in the second button&#8217;s OnClick Event handler this code:

if OpenDialog1.Execute then
  Memo1.Lines.LoadFromFile(OpenDialog1.FileName);

6. Insert in the third button&#8217;s OnClick Event handler this code:

if SaveDialog1.Execute then
  Memo1.Lines.SaveToFile(SaveDialog1.FileName);

7. Build & compile the project: the new ADO SQL Explorer is done!

The program can archive the most important queries used; it recognizes on its own the correct method to use with the given query and can be used against virtually every kind of OleDB or ODBC supported database.

The Sources of the program will be made available for download soon on my website (http://www.dreamscape.it) or can be asked directly by email to massimo.brini@dreamscape.it.

Creating a component at runtime

Problem/Question/Abstract:

I want to create a button in code, put it on a form and attach a procedure to its click event. How can I get the click event linked to a predefined procedure name from code? I assume the IDE linking in the object browser is key to the answer, but I want to do this at run time, not in development.

Answer:

Thank God for object-oriented environments! First of all, you can assign any object's method to another method as long as it has the same form. Look at the code below:

{This method is from another button that when pressed will create
the new button.}

procedure TForm1.Button1Click(Sender: TObject);
var
  btnRunTime: TButton;
begin
  btnRunTime := TButton.Create(form1);
  with btnRunTime do
  begin
    Visible := true;
    Top := 64;
    Left := 200;
    Width := 75;
    Caption := 'Press Me';
    Name := 'MyNewButton';
    Parent := Form1;
    OnClick := ClickMe;
  end;
end;

{This is the method that gets assigned to the new button's OnClick method}

procedure TForm1.ClickMe(Sender: TObject);
begin
  with (Sender as TButton) do
    ShowMessage('You clicked me');
end;

As you can see, I created a new method called ClickMe, which was declared in the private section of Form1:

type
  TForm1 = class(TForm
      ...
      ...
      private

procedure ClickMe(Sender: TObject);
published
  end;

There's no way to write code at run time, so it has to pre-exist. Fortunately with Delphi, you can perform re-assignment of methods to other methods in code. This duplicates assigning all the OnClick methods of a bunch of buttons to a single button's OnClick that you can do in the Object Inspector. You're just doing it in code.

So why does this work?

Event handlers are really nothing more than pointers to procedures. In the object code, they're declared something like the following:

type
  TNotifyEvent = procedure(Sender: TObject) of object;
  TMouseEvent = procedure(Sender: TObject; Button: TMouseButton; Shift:
    TShiftState; X, Y: Integer) of object;

Then, properties in the components are assigned these types. For instance, an OnClick for a button as seen in the Object Inspector is a TNotifyEvent and is declared in the component code as follows:

property OnClick: TNotifyEvent read FOnClick write FOnClick;

All this means is: When this event occurs, execute a method that has the structure that's what I'm expecting (the FOnClick var). In the case of OnClick, it's a method that has a single parameter of TObject &mdash (Sender : TObject). Note that I specifically say "method," which implies that the procedure must be a member function of some object (like a form or another button), and not a generic procedure.

Regarding to the FOnClick, that's just a variable with the same type as the property; as such, it can be assigned any method that has the right structure.

In some but not all components, there's underlying behavior associated with any event that's performed by Windows message handlers. For instance, sometimes it's not enough just to declare an event handler. A button also gets its "button-ness" from the Windows messages it traps as well. For an OnClick, the specific Windows message is WM_LBUTTONUP (OnClick in the help is explained as an event that occurs when the user presses the mouse button down and releases it, which is why the user code is not executed until the button is released), and that is handled in the component code behind the scenes. It executes regardless of the code you assign to the OnClick procedure, and it is executed first. So here's pecking order:

User clicks on a button.
Windows Message code gets executed to ellicit default behavior for the component.
Any code assigned to the user event handler is then executed by a specific Windows message handler.

This is stuff you don't normally hear about, and it's important to understand the intricacies behind why something works the way it does as opposed to me just giving you a "pat" answer. What I've essentially outlined here is the way in which an event handler is created. If you want more information, I suggest you get a book that deals with this. Ray Konopka's book Building Delphi Components (or something like that) is a good reference.

Converting SWF to EXE using Delphi

Problem/Question/Abstract:

Converting SWF to EXE using Delphi

Answer:

function Swf2Exe(S, D, F: string): string;
//S = Source file (swf)
//D = Destionation file (exe)
//F = Flash Player
var
  SourceStream, DestinyStream, LinkStream: TFileStream;
  flag: Cardinal;
  SwfFileSize: integer;
begin
  result := 'something error';
  DestinyStream := TFileStream.Create(D, fmCreate);
  try
    LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(LinkStream, 0);
    finally
      LinkStream.Free;
    end;

    SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(SourceStream, 0);
      flag := $FA123456;
      DestinyStream.WriteBuffer(flag, sizeof(integer));
      SwfFileSize := SourceStream.Size;
      DestinyStream.WriteBuffer(SwfFileSize, sizeof(integer));
      result := '';
    finally
      SourceStream.Free;
    end;
  finally
    DestinyStream.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Swf2Exe('c:\somefile.swf', 'c:\somefile.exe',
    'c:\Program Files\Macromedia\Flash MX\Players\SA\FlashPlayer.exe');
end;

Accessing Web Services from URL

Problem/Question/Abstract:

How can I access the web service through my application

Answer:

This article describes how to call the web services from your application. The MSSoap client ole object will allow the application to make remote procedure calls to the web server over the internet. So we need to create a ole object i.e the "MSSoap.Soapclient" in our application. For this, Microsoft Soap ToolKit must be installed in the machine where the application is running.

For this example will be using the "CurrencyExchangeService" webservice which is provided by www.xmethods.net. This web service gives the currency value of the Country2 with respect to Country1.

function getrate(Country1, Country2: string): Double;
var
  SoapClient: OleVariant;
  vRate: string;
  vURL: string;
begin
  vURL := 'http://www.xmethods.net/sd/CurrencyExchangeService.wsdl';
  vRate := 0;
  try
    SoapClient := CreateOleObject('MSSOAP.SoapClient');
  except
  end;
  try
    SoapClient.mssoapinit(vURL);
    //GetRate is the function in the Web service
    vRate := SoapClient.GetRate(Country1, Country2);
  except
  end;
  try
    FreeAndNil(SoapClient);
  except
  end;
  Result := StrToFloat(vRate);
end;

Draw a line from the mouse cursor to a fixed point on a form

Problem/Question/Abstract:

How to draw a line from the mouse cursor to a fixed point on a form

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    fOldX, fOldY: Integer;
    fLineDrawn: Boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  fLineDrawn := false;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

  procedure DrawLine(Color: TColor);
  begin
    Canvas.Pen.Color := Color;
    Canvas.MoveTo(fOldX, fOldY);
    Canvas.LineTo(100, 100);
  end;

begin
  if fLineDrawn then
    DrawLine(Color);
  fOldX := X;
  fOldY := Y;
  DrawLine(clRed);
  fLineDrawn := true;
end;

end.

Save all TWebbrowser frame sources

Problem/Question/Abstract:

How to save all TWebbrowser frame sources

Answer:

uses
ActiveX;

function TForm1.GetFrame(FrameNo: Integer): IWebbrowser2;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
Application.ProcessMessages;
if Assigned(Webbrowser1.document) then
begin
Fetched := nil;
OleContainer := Webbrowser1.Document as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebbrowser2;
end
else
Result := nil;
end;

// Load sample page

procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('http://www.warebizprogramming.com/tutorials/html/framesEx1.htm');
end;

// Save all frames in single files

procedure TForm1.Button2Click(Sender: TObject);
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
iw: IWebbrowser2;
i: Integer;
sl: TStringList;
begin
for i := 0 to Webbrowser1.OleObject.Document.frames.Length - 1 do
begin
iw := GetFrame(i);
AStream := TMemoryStream.Create;
try
IpStream := iw.document as IPersistStreamInit;
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), True)) then
begin
AStream.Seek(0, 0);
sl := TStringList.Create;
sl.LoadFromStream(AStream);
sl.SaveToFile('c:\frame' + IntToStr(i) + '.txt');
//  memo1.Lines.LoadFromStream(AStream);
sl.Free;
end;
except
end;
AStream.Free;
end;
end;

end.

Enable / disable single items in a TRadioGroup

Problem/Question/Abstract:

How can I set single Items.Strings in RadioGroups to Enabled := True or Enabled := False ?

Answer:

Solve 1:

TControl(RadioGroup1.Components[0]).Enabled := false;
TControl(RadioGroup1.Components[1]).Enabled := true;


Solve 2:

This function allows you to modify TRadioButtons in a given RadioGroup. Of course you can modify this to search not for a caption but for an index:

function ButtonOfGroup(rg: TRadioGroup; SearchCaption: string): TRadioButton;
var
i: Integer;
begin
Result := nil;
for i := 0 to rg.ComponentCount - 1 do
if (rg.Components[i] is TRadioButton) and
(CompareStr(TRadioButton(rg.Components[i]).Caption, SearchCaption) = 0) then
begin
Result := TRadioButton(rg.Components[i]);
Break;
end;
end;


Solve 3:

The following code shows how to disable or enable an individual radio button in a TRadioGroup component (the second radio button in this case). Note that the RadioGroup.Controls is a zero based array.

procedure TForm1.Button1Click(Sender: TObject);
begin
TRadioButton(RadioGroup1.Controls[1]).Enabled := False;
end;

How to stop the DBGrid control from auto-appending a new entry

Problem/Question/Abstract:

How can I stop the DBGrid control from auto-appending a new entry?

Answer:

// Torry's Delphi Tips
// Author Damian Gorski
// Listed 24.02.2003
{How to stop the dbgrid control from auto-appending a new entry when you move
down after the last record in a table.
It creates a new blank line / record in the table. Can this be stopped?}

{A: Add to your TTables's "BeforeInsert"  event the following line:}

procedure TForm1.Tbable1BeforeInsert(DataSet: TDataSet);
begin
Abort; {<<---this line}
end;

{A: It traps the down key and checks for end-of-file.}

procedure TForm8.DBGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_DOWN) then
begin
TTable1.DisableControls;
TTable1Next;
if TTable1.EOF then
Key := 0
else
TTable1.Prior;
TTable1.EnableControls;
end;
end;

Implementation of Wake On Lan procedure

Problem/Question/Abstract:

This procedure will switch on a machine that is connected to a LAN. The MAC address of the machine is needed to be known. See my article "Get MAC Address of Remote or Local" for a function GetMacAddress() that returns a MAC Address String.

The "Wake On Lan" feature of the machine's BIOS must be enabled.

The procedure works by broadcasting a UDP packet containing the "Magic Number" to all machines on the LAN. The machine with the MAC address, if switched of and BIOS WOL enabled will wake up and boot.

The MAC address required is a "-" delimited 17 char string.

Example :

WakeOnLan('00-D0-B7-E2-A1-A0');

Answer:

uses idUDPClient;

// ==========================================================================
// Wakes a machine on lan
// AMacAddress is 17 char MAC address.
// eg.  '00-C0-4F-0A-3A-D7'
// ==========================================================================

procedure WakeOnLan(const AMacAddress: string);
type
TMacAddress = array[1..6] of byte;

TWakeRecord = packed record
Waker: TMACAddress;
MAC: array[0..15] of TMACAddress;
end;

var
i: integer;
WR: TWakeRecord;
MacAddress: TMacAddress;
UDP: TIdUDPClient;
sData: string;
begin
// Convert MAC string into MAC array
fillchar(MacAddress, SizeOf(TMacAddress), 0);
sData := trim(AMacAddress);

if length(sData) = 17 then
begin
for i := 1 to 6 do
begin
MacAddress[i] := StrToIntDef('$' + copy(sData, 1, 2), 0);
sData := copy(sData, 4, 17);
end;
end;

for i := 1 to 6 do
WR.Waker[i] := $FF;
for i := 0 to 15 do
WR.MAC[i] := MacAddress;
// Create UDP and Broadcast data structure
UDP := TIdUDPClient.Create(nil);
UDP.Host := '255.255.255.255';
UDP.Port := 32767;
UDP.BroadCastEnabled := true;
UDP.SendBuffer(WR, SizeOf(TWakeRecord));
UDP.BroadcastEnabled := false;
UDP.Free;
end;

Change the color of a disabled TEdit

Problem/Question/Abstract:

How can I change the color of a disabled (Edit1.Enabled := false;) control? I do not want the normal grey color.

Answer:

Two options: Place the control on a panel and disable the panel instead of the control. This way the color stays to whatever you set it. Or make a descendent and take over the painting when it is disabled. Here is an example:

unit PBExEdit;

interface

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

type
TPBExEdit = class(Tedit)
private
{ Private declarations }
FDisabledColor: TColor;
FDisabledTextColor: TColor;
procedure WMPaint(var msg: TWMPaint); message WM_PAINT;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure SetDisabledColor(const Value: TColor); virtual;
procedure SetDisabledTextColor(const Value: TColor); virtual;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(aOwner: TComponent); override;
published
{ Published declarations }
property DisabledTextColor: TColor read FDisabledTextColor write
SetDisabledTextColor
default clGrayText;
property DisabledColor: TColor read FDisabledColor write SetDisabledColor default
clWindow;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('PBGoodies', [TPBExEdit]);
end;

constructor TPBExEdit.Create(aOwner: TComponent);
begin
inherited;
FDisabledColor := clWindow;
FDisabledTextColor := clGrayText;
end;

procedure TPBExEdit.SetDisabledColor(const Value: TColor);
begin
if FDisabledColor <> Value then
begin
FDisabledColor := Value;
if not Enabled then
Invalidate;
end;
end;

procedure TPBExEdit.SetDisabledTextColor(const Value: TColor);
begin
if FDisabledTextColor <> Value then
begin
FDisabledTextColor := Value;
if not Enabled then
Invalidate;
end;
end;

procedure TPBExEdit.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
canvas: TCanvas;
begin
if Enabled then
inherited
else
begin
canvas := TCanvas.Create;
try
canvas.Handle := msg.DC;
SaveDC(msg.DC);
try
canvas.Brush.Color := FDisabledColor;
canvas.Brush.Style := bsSolid;
canvas.Fillrect(clientrect);
msg.result := 1;
finally
RestoreDC(msg.DC, -1);
end;
finally
canvas.free
end;
end;
end;

procedure TPBExEdit.WMPaint(var msg: TWMPaint);
var
canvas: TCanvas;
ps: TPaintStruct;
callEndPaint: Boolean;
begin
if Enabled then
inherited
else
begin
callEndPaint := False;
canvas := TCanvas.Create;
try
if msg.DC <> 0 then
begin
canvas.Handle := msg.DC;
ps.fErase := true;
end
else
begin
BeginPaint(handle, ps);
callEndPaint := true;
canvas.handle := ps.hdc;
end;
if ps.fErase then
Perform(WM_ERASEBKGND, canvas.handle, 0);
SaveDC(canvas.handle);
try
canvas.Brush.Style := bsClear;
canvas.Font := Font;
canvas.Font.Color := FDisabledTextColor;
canvas.TextOut(1, 1, Text);
finally
RestoreDC(canvas.handle, -1);
end;
finally
if callEndPaint then
EndPaint(handle, ps);
canvas.free
end;
end;
end;

end.

Calling a C++ DLL which exports a class

Problem/Question/Abstract:

As I stated in an earlier article, it's possible to get an object-reference out from a DLL. This technique is known under the name DLL+. But how about the DLL is written in c++?

Answer:

First of all, you have to translate the header-file (should be delivered with the DLL), which is like an interface-section in ObjectPascal. Headers in c usually contain all sorts of definitions which are relevant outside the
module. In our c++ example it looks like:

/*FILE: income.h */
class CIncome
{
public:
virtual double __stdcall GetIncome( double aNetto ) = 0 ;
virtual void   __stdcall SetRate( int aPercent, int  aYear ) = 0 ;
virtual void   __stdcall FreeObject() = 0 ;
} ;

Then you translate it to an Abstract Class in a unit of her own:

//FILE: income.pas
interface
type
IIncome = class
public
function GetIncome(const aNetto: double): double;
virtual; stdcall; abstract;
procedure SetRate(const aPercent: Integer; aYear: integer);
virtual; stdcall; abstract;
procedure FreeObject; virtual; stdcall; abstract;
end;

In the c++ dll, there is a procedure FreeObject this is necessary because of differences in memory management between C++ and ObjectPascal:

void __stdcall FreeObject()
{
delete this ;
}

When you call the DLL written in C or C++, you have to use the stdcall or cdecl convention. Otherwise, you
will end up in violation troubles and from time to time the application may crash. By the way the DLL, you are calling, should be on the search path;).

So these conventions pass parameters from right to left. With this convention, the caller (that's Delphi)has to remove the parameters from the stack when the call returns.

At least the DLL-call is simple:

incomeRef: IIncome; //member of the reference

function CreateIncome: IIncome;
stdcall; external('income_c.dll');

procedure TfrmIncome.FormCreate(Sender: TObject);
begin
incomeRef := createIncome;
end;

procedure TfrmIncome.btncplusClick(Sender: TObject);
var
cIncome: Double;
begin
// this is the c++ dll+ call ;)
incomeRef.SetRate(strToInt(edtZins.text),
strToInt(edtJahre.text));
cIncome := incomeRef.GetIncome(StrToFloat(edtBetrag.Text));
edtBetrag.text := Format('%f', [cIncome]);
end;


Component Download: http://max.kleiner.com/download/cpluscall.ziphttp://max.kleiner.com/download/cpluscall.zip

Wait until a TForm is actually painted on screen

Problem/Question/Abstract:

How can I wait until the form is actually painted on screen, before starting the processing so that I can be sure that any exceptions are displayed after the form is painted. I've considered a short timer in the OnCreate. Is there a better way (i.e. catching a Windows message)?

Answer:

Use an custom message:

const
  UM_AFTERSHOW = WM_USER + 1001;

type
  TMyForm = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    procedure UMAfterShow(var Msg: TMessage); message UM_AFTERSHOW;
  end;

implementation

procedure TMyForm.FormShow(Sender: TObject);
begin
  PostMessage(Self.Handle, UM_AFTERSHOW, 0, 0);
end;

procedure TMyForm.UMAfterShow(var Msg: TMessage);
begin
  {your code here}
end;

How to write a custom TAction to control the visibility of a TStatusBar

Problem/Question/Abstract:

I am trying to write a custom action that will set the visible property of a TStatusBar on and off. I assigned this action to a menu item and when I select this menu item at runtime the status bar is hidden. The problem is that the menu item (connected to the action) is disabled, so I can't view the statusbar again. I think that it's a matter of how the TMenuActionLink behaves (the action controls the enabled property of the menu ). I tried to set the enabled property in the action to true , but no avail. The menu is still disabled. Is there any way to do this?

Answer:

I think that the best solution would be to write an action, which will have a StatusBar property and, in case this property was assigned, set the statusbar's visibility in the overridden Execute method. Here's an example:

{ ... }
TMyAction = class(TAction)
protected
  FStatusBar: TStatusBar;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  procedure SetStatusBar(AValue: TStatusBar);
public
  constructor Create(AOwner: TComponent); override;
  function Execute: Boolean; override;
published
  property StatusBar: TStatusBar read FStatusBar write SetStatusBar;
end;

{ ... }

constructor TMyAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DisableIfNoHandler := false;
  FStatusBar := nil;
  Caption := 'Turn On/ Off Status Bar';
end;

function TMyAction.Execute: Boolean;
begin
  Result := inherited Execute;
  if Assigned(FStatusBar) then
  begin
    FStatusBar.Visible := not FStatusBar.Visible;
    Checked := FStatusBar.Visible;
  end;
end;

procedure TMyAction.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = StatusBar) then
    StatusBar := nil;
end;

procedure TMyAction.SetStatusBar(AValue: TStatusBar);
begin
  if FStatusBar <> AValue then
  begin
    FStatusBar := AValue;
    if Assigned(FStatusBar) then
    begin
      FStatusBar.FreeNotification(Self);
      Checked := FStatusBar.Visible;
    end
    else
      Checked := false;
  end;
end;

TMediaPlayer: What track am I on?

Problem/Question/Abstract:

TMediaPlayer: What track am I on?

Answer:

Although writing multimedia applications using Delphi is a three-step process (click, drag and drop!), some people still ask how to find out what track is currently playing on the CD player. Just get that info, just drop a TMediaPlayer component on the form, with all the properties correctly set and bound to the CD player. Also, add "MMSystem" to the uses clause in the calling form. To complete, create a TTimer and put the code below in its OnTimer event:

var
  Trk, Min, Sec: word;
begin
  with MediaPlayer1 do
  begin
    Trk := MCI_TMSF_TRACK(Position);
    Min := MCI_TMSF_MINUTE(Position);
    Sec := MCI_TMSF_SECOND(Position);
    Label1.Caption := Format('%.2d', [Trk]);
    Label2.Caption := Format('%.2d:%.2d', [Min, Sec]);
  end;
end;

How to create a brush using CreateBrushIndirect

Problem/Question/Abstract:

How to create a brush using CreateBrushIndirect

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  Region: HRGN;
  LogBrush: TLogBrush;
  NewBrush: hBrush;
begin
  with LogBrush do
  begin
    lbStyle := BS_HATCHED;
    lbColor := clBlue;
    lbHatch := HS_CROSS
  end;
  NewBrush := CreateBrushIndirect(LogBrush);
  Region := CreateEllipticRgnIndirect(PaintBox1.BoundsRect);
  FillRgn(PaintBox1.Canvas.Handle, Region, NewBrush);
  DeleteObject(NewBrush);
  DeleteObject(Region)
end;

SQL Server Security Setting

Problem/Question/Abstract:

How I can Set SQL Server Security in SQL Server Authentication without windows Authentication.

Answer:

You must install new sql server and set authentication in mix mode or SQL Server and Windows authentication.

In Sql Manager, Add New Group and add New SQL Server and set connection type to SQL Server Authentication with checking check box (Always Prompt).

In Security/Login Section you should set BUILTIN/Adminstrator to Access Deny.

Every Users with windows authentication should had appropriate access with Deny Access.

Every Users with Funcional access such as creating, droping,... tables should had SQL Server Authentication with appropriate Password.

Sa should SQL Authentication wih appropriate password.

Change the color of the tabs on a PageControl

Problem/Question/Abstract:

How do I change the color of the tabs on a PageControl?

Answer:

The example below uses the OnDrawCell event to change the colour of the active Tab and of the Font used:

procedure TForm1.TabControl1DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  s: string;
  r: TRect;
begin
  s := form1.TabControl1.Tabs.Strings[tabindex];
  r := Rect;
  with Control.Canvas do
  begin
    if Active then
    begin
      Brush.Color := clinfoBK;
      Font.Color := clBlue;
    end;
    Windows.FillRect(Handle, r, Brush.Handle);
    OffsetRect(r, 0, 1);
    DrawText(Handle, PChar(s), Length(s), r, DT_CENTER or DT_SINGLELINE or
      DT_VCENTER);
  end;
end;

How to create a pie chart

Problem/Question/Abstract:

Can anyone point me in the direction of an code snippet for drawing a pie/ circle given the following definition:

procedure Pie(ACanvas: TCanvas; ACenter: TPoint; ARadius: Integer; AStartDeg, AEndDeg: Float);

which draws a pie as a section of a circle starting at AStartDeg dregrees (0 being straight up - or whatever) and ending at AEndDeg (360 beging straight up - or whatever) using ACanvas default drawing parameters (brush and pen).

Answer:

The TCanvas.Pie can be used to get what you want - with a little trig. The following has 0 degrees being to the right (as in trig classes) witha positive angle in the counterclockwise direction (as in trig classes):

uses
  Math; {DegToRad}

procedure DrawPieSlice(const Canvas: TCanvas; const Center: TPoint;
  const Radius: Integer; const StartDegrees, StopDegrees: Double);
const
  Offset = 0; {to make 0 degrees start to the right}
var
  X1, X2, X3, X4: Integer;
  Y1, Y2, Y3, Y4: Integer;
begin
  X1 := Center.X - Radius;
  Y1 := Center.Y - Radius;
  X2 := Center.X + Radius;
  Y2 := Center.Y + Radius;
  {negative signs on "Y" values to correct for "flip" from normal math defintion for "Y" dimension}
  X3 := Center.X + Round(Radius * COS(DegToRad(Offset + StartDegrees)));
  Y3 := Center.y - Round(Radius * SIN(DegToRad(Offset + StartDegrees)));
  X4 := Center.X + Round(Radius * COS(DegToRad(Offset + StopDegrees)));
  Y4 := Center.y - Round(Radius * SIN(DegToRad(Offset + StopDegrees)));
  Canvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Center: TPoint;
  Bitmap: TBitmap;
  Radius: Integer;
begin
  Assert(Image1.Width = Image1.Height); {Assume square for now}
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := Image1.Width;
    Bitmap.Height := Image1.Height;
    Bitmap.PixelFormat := pf24bit;
    Bitmap.Canvas.Brush.Color := clRed;
    Bitmap.Canvas.Pen.Color := clBlue;
    Center := Point(Bitmap.Width div 2, Bitmap.Height div 2);
    Radius := Bitmap.Width div 2;
    DrawPieSlice(Bitmap.Canvas, Center, Radius, 0, 30);
    DrawPieSlice(Bitmap.Canvas, Center, Radius, 90, 120);
    Image1.Picture.Graphic := Bitmap;
  finally
    Bitmap.Free;
  end;
end;

How to control the volume of an audio card without disturbing the balance

Problem/Question/Abstract:

I can easily adjust the left and right channels independently on an audio card using the mixer API. My question is: How do I have one trackbar set the overall volume without disturbing the current balance between channels? Or how do I use two trackbars, but "lock" them together? Basically I need to directly manipulate one channel, but have the other one follow while keeping the relative relationship between the two channels the same.

Answer:

Here is the method I use. It uses a mixer component though, but I believe the code should make sense.


procedure setVolume(percent: real);
var
  value: integer;
  balance: real;
  highChannel, lowChannel: byte;
begin
  if percent > 1 then
    percent := 1;
  if percent < 0 then
    percent := 0;
  value := high(word) - round(percent * high(word));
  if value > high(word) then
    value := high(word);
  if value < 0 then
    value := 0;
  aMixer.outputs[0].inputs[0].volume.beginUpdate;
  if (aMixer.outputs[0].inputs[0].Volume.position[0] = 0) and
    (aMixer.outputs[0].inputs[0].Volume.position[1] = 0) then
  begin
    {Both are muted, get old balance}
    if oldBalance = 10 then
      {oldBalance is set to 10 on program start (dummy value)}
    begin
      balance := 1;
      highChannel := 0;
      lowChannel := 1
    end
    else
    begin
      if oldBalance < 0 then
      begin
        highChannel := 0;
        lowChannel := 1;
        balance := oldBalance * -1
      end
      else
      begin
        highChannel := 1;
        lowChannel := 0;
        balance := oldBalance
      end
    end
  end
  else
  begin
    if aMixer.outputs[0].inputs[0].Volume.position[0] >
      aMixer.outputs[0].inputs[0].Volume.position[1] then
    begin
      highChannel := 0;
      lowChannel := 1
    end
    else
    begin
      highChannel := 1;
      lowChannel := 0
    end;
    balance := aMixer.outputs[0].inputs[0].Volume.position[lowChannel] /
      aMixer.outputs[0].inputs[0].Volume.position[highChannel]
  end;
  aMixer.outputs[0].inputs[0].Volume.position[highChannel] := value;
  aMixer.outputs[0].inputs[0].Volume.position[lowChannel] := round(value * balance);
  if value > 0 then
  begin
    oldBalance := balance;
    if highChannel = 0 then
      oldBalance := oldBalance * -1
  end;
  aMixer.outputs[0].inputs[0].volume.endUpdate
end;

Check if the current printer is ready to print in color

Problem/Question/Abstract:

How can I find out whether the current printer is ready to print in colour, rather than just capable of printing in colour?

Answer:

Solve 1:

This works for some but not all printers, depending on the driver capabilities:

{ ... }
var
  Dev, Drv, Prt: array[0..255] of Char;
  DM1: PDeviceMode;
  DM2: PDeviceMode;
  Sz: Integer;
  DevM: THandle;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Dev, Drv, Prt, DevM);
  DM1 := nil;
  DM2 := nil;
  Sz := DocumentProperties(0, 0, Dev, DM1^, DM2^, 0);
  GetMem(DM1, Sz);
  DocumentProperties(0, 0, Dev, DM1^, DM2^, DM_OUT_BUFFER);
  if DM1^.dmColor > 1 then
    Label1.Caption := Dev + ': Color'
  else
    Label1.Caption := Dev + ': Black and White';
  if DM1^.dmFields and DM_Color <> 0 then
    Label2.Caption := 'Printer supports color printing'
  else
    Label2.Caption := 'Printer does not support color printing';
  FreeMem(DM1);
end;


Solve 2:

function IsColorPrinter: bool;
var
  Device: array[0..MAX_PATH] of char;
  Driver: array[0..MAX_PATH] of char;
  Port: array[0..MAX_PATH] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  result := False;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
  begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then
    begin
      if ((pDMode^.dmFields and dm_Color) = dm_Color) then
      begin
        result := True;
      end;
      GlobalUnlock(hDMode);
    end;
  end;
end;

function SetPrinterColorMode(InColor: bool): bool;
var
  Device: array[0..MAX_PATH] of char;
  Driver: array[0..MAX_PATH] of char;
  Port: array[0..MAX_PATH] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  result := False;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
  begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then
    begin
      if (pDMode^.dmFields and dm_Color) = dm_Color then
      begin
        if (InColor) then
        begin
          pDMode^.dmColor := DMCOLOR_COLOR;
        end
        else
        begin
          pDMode^.dmColor := DMCOLOR_MONOCHROME;
        end;
        result := True;
      end;
      GlobalUnlock(hDMode);
      Printer.PrinterIndex := Printer.PrinterIndex;
    end;
  end;
end;


Solve 3:

It is usually better to use DeviceCapabilities to examine what the printer supports. Unfortunately this will only work on Win2K and XP, not on older platforms.

uses
  printers, winspool;

function PrinterSupportsColor: Boolean;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  Result := WinSpool.DeviceCapabilities(Device, Port, DC_COLORDEVICE, nil, nil) <> 0;
end;

Bold nodes in standard TTreeview component

Problem/Question/Abstract:

How make a some nodes in standard TTreeview component as bold?

Answer:

Me frequently ask as I in SMReport Explorer form realized selection by the bold font some nodes.

Today I have decided to describe this very simple way (but very useful). It does not require an override of any custom drawing methods/events, creating a new component etc. It's a real standard way.

The standard Windows Treeview control have a few state flags (TVIS_BOLD and TVIS_CUT in our example), due to which it's possible to reach wished.

At first, let's write the procedure SetNodeState:

procedure SetNodeState(node: TTreeNode; Flags: Integer);
var
  tvi: TTVItem;
begin
  FillChar(tvi, SizeOf(tvi), 0);
  tvi.hItem := node.ItemID;
  tvi.Mask := TVIF_STATE;
  tvi.StateMask := TVIS_BOLD or TVIS_CUT;
  tvi.State := Flags;
  TreeView_SetItem(node.Handle, tvi);
end;

And now we can set a wished flags:

SetNodeState(node, TVIS_BOLD) - to set the node as Bold
SetNodeState(node, TVIS_CUT) - to set the node as Cutted
SetNodeState(node, TVIS_BOLD or TVIS_CUT) - to set the node as Bold and Cutted
SetNodeState(node, 0) - to set a node as normal

How to do syntax highlighting in a TRichEdit

Problem/Question/Abstract:

How to do syntax highlighting in a TRichEdit

Answer:

{Content of the TRichEdit for example:

This is a test to show how to find the @ character in a rich text.
The @ character occurs twice in the text.
}

procedure MarkFirstWord(RE: TRichEdit; TheWord: string; Color: TColor; Style:
  TFontStyles);
var
  i, CharPos, noChars: Integer;
begin
  CharPos := 0;
  noChars := 0;
  for i := 0 to Pred(RE.Lines.Count) do
    noChars := noChars + Length(RE.Lines[i]);
  CharPos := RE.FindText(TheWord, CharPos, noChars, [stWholeWord]);
  RE.SelStart := CharPos;
  RE.SelLength := Length(TheWord);
  RE.SelAttributes.Color := Color;
  RE.SelAttributes.Style := Style;
  RE.SelLength := 0;
end;

procedure MarkAllWords(RE: TRichEdit; TheWord: string; Color: TColor; Style:
  TFontStyles);
var
  i, CharPos, CharPos2, noChars: Integer;
begin
  CharPos := 0;
  noChars := 0;
  for i := 0 to Pred(RE.Lines.Count) do
    noChars := noChars + Length(RE.Lines[i]);
  repeat
    CharPos2 := RE.FindText(TheWord, CharPos, noChars, [stWholeWord]);
    CharPos := CharPos2 + 1;
    RE.SelStart := CharPos2;
    RE.SelLength := Length(TheWord);
    RE.SelAttributes.Color := Color;
    RE.SelAttributes.Style := Style;
  until
    charpos = 0;
  RE.SelLength := 0;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Will mark only the first occurance of '@' in Red}
  MarkFirstWord(RichEdit1, '@', clRed, [fsBold]);
  {Will mark all occurances of @ in Teal and italic}
  MarkAllWords(RichEdit1, '@', clTeal, [fsItalic, fsBold]);
end;

Implement forms that are modal only towards their owner form

Problem/Question/Abstract:

I have a form of which any number of instances can be created and used at once. From each of these forms the user can open another form. This form must however be modal to its creator (the first form), but not to the rest of the application.

Answer:

Create the modal form with the calling form as Owner, not with pplication as owner. In the modal form override the CreateParams method as

{ ... }
inherited;
params.WndParent := (Owner as TForm).handle;

Add a public class function to the modal form:

class function ShowForm(aOwner: TForm): TModalform;

implemented as

class function TModalForm.ShowForm(aOwner: TForm): TModalForm;
begin
  Result := TModalForm.Create(aOwner);
  aOwner.Enabled := False;
  Result.Show;
end;

Use this method to create instances of the form instead of calling the constructor directly. We also need a handler for OnClose that does

Action := caFree;
(Owner as TForm).Enabled := true;

If you do need to communicate back a modal result to the caller you will need to add a public event to the pseudomodal form to which the caller can attach a handler. This event would then be called from the OnClose event handler, passing the modalresult. Note that any buttons that should close the form with a modalresult need to explicitely call the Close method, since the modal message loop is not used that will not happen on its own.