How to draw on the Desktop

Problem/Question/Abstract:

I'd like to draw on the screen, and not necessarily in the application form. Example: When the application is running but the form is minimized, I'd like to be able to draw a circle on the desktop.

Answer:

procedure THovedForm.Tegn1ButtonClick(Sender: TObject);
var
  DesktopDC: HDC;
  Rectangle: TRect;
  pcTekst: PChar;
begin
  DesktopDC := GetWindowDC(GetDesktopWindow);
  MoveToEx(DesktopDC, 0, 0, nil);
  LineTo(DesktopDC, Screen.Width, Screen.Height);
  MoveToEx(DesktopDC, 0, Screen.Height, nil);
  LineTo(DesktopDC, Screen.Width, 0);
  pcTekst := 'Finn Tolderlund';
  SetTextColor(DesktopDC, clBlue);
  Rectangle.Left := 150;
  Rectangle.Top := 250;
  Rectangle.Right := 150 + 100;
  Rectangle.Bottom := 250 + 100;
  SetBkMode(DesktopDC, Transparent);
  DrawTextEx(DesktopDC, pcTekst, -1, Rectangle, DT_CENTER or DT_NOCLIP, nil);
  ReleaseDC(GetDesktopWindow, DesktopDC);
end;

How to get a list of Parallel ports on a PC

Problem/Question/Abstract:

How to get a list of Parallel ports on a PC

Answer:

function PortExists(const PortName: string): Boolean;
var
  hPort: HWND;
begin
  Result := False;
  hPort := CreateFile(PChar(PortName), {name}
    GENERIC_READ or GENERIC_WRITE, {access attributes}
    0, {no sharing}
    nil, {no security}
    OPEN_EXISTING, {creation action}
    FILE_ATTRIBUTE_NORMAL or
    FILE_FLAG_OVERLAPPED, {attributes}
    0); {no template}
  if hPort <> INVALID_HANDLE_VALUE then
  begin
    CloseHandle(hPort);
    Result := True;
  end;
end;

{Parallel Ports}
for i := 1 to 9 do
begin
  if PortExists('LPT' + IntToStr(i)) then
    List.Append('Ports: Printer Port (LPT' + IntTostr(i) + ')');
end;

Inside Delphi's Classes and Interfaces Part II

Problem/Question/Abstract:

You've probably used classes & interfaces more than once in your delphi programs. Did you ever dtop to think how delphi implements this creatures ?

Answer:

Inorder to understand this article, you must read the previous article (Inside Delphi's Classes and Interfaces Part I).
In this article we'll finish covering Delphi's implementation of Interfaces, and review a few usefull conclusions.

Let's start with an indepth example :

type

  IInterface1 = interface
    procedure ActA;
    procedure ActB;
  end;

  IInterface2 = interface(IInterface1)
    procedure ActC;
    procedure ActD; stdcall;
  end;

  TSampleClass = class(TInterfacedObject, IInterface1, IInterface2)
    procedure ActA;
    procedure ActB;
    procedure ActC;
    procedure ActD; stdcall;
  end;

var
  Interface1: IInterface1;
  Interface2: IInterface2;
  Sample: TSampleClass;
begin
  Sample := TSampleClass.Create;
  Interface1 := Sample;
  Interface2 := Sample;
  Interface1.ActA;
  Interface1.ActB;
  Interface2.ActA;
  Interface2.ActB;
  Interface2.ActC;
  Interface2.ActD;
end;

Instead of looking at the compiled code for this example, I'll simlpy note the interesting aspects of it. First, when assigning a value to Interface1, we'd expect delphi to take the value of  what 'Sample' points to and add a specific amount ($10) and be done with it. When assigning a value to Interface2, we'd expect delphi to do the same, just add a smaller amount ($0C) because the interfaces are stored in memory from the last to the first.
But delphi doesn't do that. It assignes both Interface1 AND Interface2 the value that 'Sample' points to plus $0C. That's because IInterface2 inherites from IInterface1. Therefor,  IInterface2 includes IInterface1. Hence, any call to Interface1, will actually be executed through IInterface2's method list.

Second, when we call Interface1.ActA, it calles the 4th (every interface inherites from IUnknown) method on IInterface2's method list (because IInterface2 inherites from IInterface1). When we call Interface1.ActB it calles the 5th method on IInterface2's method list. When we call Interface2.ActA it calles the 4th method on IInterface2's method list, just the same as Interface1.ActA. That's because IInterface2 inherites from IInterface1.

Third, when we call Interface2.ActD delphi addes one additional instruction before calling the 7th method of IInterface2. That's because we've declared a different convention call to the method (stdcall). Notice that all of IUnknown's methods are defined with the stdcall directive.

The structor of an interface's method list always follows the following rule :

First Method
.
.
Last Method
The parent's interface's method list

In our case, IInterface2's method list is as follows :
  
ActC
ActD
// IInterface1's method list
   ActA
   ActB
   // IUnknown's method List
      QueryInterface
     _AddRef
     _Release

NOTE : The structor above is how the methods' code is organized in memory. The first entry in any interface's method list will belong to QueryInterface (the first method of IUnknown) but it will point to a place in memory (the implementation of that specific interface's QueryItnerface method) that is higher than the interfaces' own methods' implementation - as shown in the structor above. In our case, IInterface2's QueryInterface's implementation is higher in memory than IInterface2's ActB's implementation, which is higher in memory than ActD's implementation. Thou ActD is the 7th entry, ActB is the 5th entry and QueryInterface is the 1st entry in IInterface2's method list.

To fully understand what happens when delphi calls an interface's method, lets have a look at the compiled method list of IInterface2 in the example above. The following code is an exact copy of the compiled code (except for the comments) :

// ActC
add eax, -$0C
jmp TSampleClass.ActC
// ActD
add dword ptr[esp + $04], -$0C
jmp TSampleClass.ActD
// ActA
add eax, -$0C
jmp TSampleClass.ActA
// ActB
add eax, -$0C
jmp TSampleClass.ActB
// QueryInterface
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject.QueryInterface
// _AddRef
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject._AddRef
// _Release
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject._Release

As you remember, an object's method is actually a regular function/procedure that accepts as a parameter an instance of the method's class. As you can notice, before each call to the real method ('TSampleClass.ActD' for example) there is one line of code that changes the value of either 'eax', or 'dword ptr [esp + $04]', depending on the calling convention. As you can notice, in all cases we subtract $0C form a variable. But, why 12 ($0C = 12) ? That's because this interface (IInterface2) is in the 3rd (FRefcount, IUnknown are before it) place after the pointer to VMT of the clasS TSampleClass. Therefore, the value of any instance of IInterface2 of TSampleClass (Interface2 for example) is actually the value of the pointer to that class' instance plus 12.

Here is another example that will help understand the section above. The following code continues the defenitions from the above code :

type

  IAnotherInterface = interface
    procedure ActE;
  end;

  TAnotherSample = class(TInterfacedObject, IInterface2, IAnotherInterface)
    procedure ActA;
    procedure ActB;
    procedure ActC;
    procedure ActD; stdcall;
    procedure ActE;
  end;

var
  Interface2: IInterface2;
begin
  Interface2 := TAnotherSample.Create;
  Interface2.ActC;
end;

Now, let's compare the entry for this example's IInterface2 and the previous' one :

IInterface2 of TAnotherSample:
add eax, -$10
jmp TAnotherSample.ActC

IInterface2 of TSampleClass:
add eax, -$0C
jmp TSampleClass.ActC

There are two obvious changes :

The actuall function that is called (either TAnotherSample.ActC or TSampleClass.ActC)  
The amount that 'eax' is changed by. Notice that when calling IInterface2 of TAnotherSample, 'eax' is changed by 16 ($10 = 16) as opposed to being changed by 12. That's because on TAnotherSample, the IInterface2 is the second interface in the instance's structor in memory, and therefor it is "farther away" from the instance itself and needs to be changed by additional 4 bytes.

And now to some usefull sutff :

First, if you want to check if 2 (or more) interface variables are of the same instance, you cannot simply compare them, even if they are of the same type. You must QueryInterface them to a single interface type, and then compare. As a general rule, if you want to compare interfaces, QueryInterface them to IUnknown and then compare.

Example :

type

  IBooA = interface
  end;

  IBooB = interface
  end;

  TBoo = class(TInterfacedObject, IBooA, IBooB)
  end;

var
  Boo: TBoo;
  BooA: IBooA;
  BooB: IBooB;
begin
  Boo := TBoo.create;
  BooA := Boo;
  BooB := Boo;

  // This won't complie
  if BooA = BooB then
  begin
    Beep;
  end;

  if Integer(BooA) = Integer(BooB) then
  begin
    // will never get here
    Beep;
  end;

  if IUnknown(BooA) = IUnknown(BooB) then
  begin
    // will never get here
    Beep;
  end;

  // the 'as' word is the same as QueryInterface when acting on interfaces
  if (BooA as IUnknown) = (BooB as IUnknown) then
  begin
    // Will always get here
    Beep;
  end;
end;

Explaination : The first comparing won't complie, becuase BooA and BooB are of 2 different types. The Second and third comparings will complie but never return true. That's because type casting doesn't change the value of the variable that's being type casted. It only allows the complier to complie the code though there are two different types involved. Hence, if BooA is different from BooB, comparing them will never return true, no matter what type casting is done to them.
But why do BooA and BooB have different values ? They were both assigned using the ":= Boo;" statment. The answer is simple. Remeber that I said that an interface's variable's value is actually the value of the instance itself (or at least the value of the pointer to the instance) plus a different number for each interface ? In our case, BooA is the same as what Boo points to, added 16. And BooB is the same as what Boo points to, added 12. That's why BooA and BooB are not that same.
The Forth comparing actually works. That's because if an interface is from the same type, then comparing it to an interface of that type will always return the expected result (if both interfaces were aquired via QueryInterface, not by type casting). That's because if they are of the same type, then the difference between them and the instance is the same. And if they are of the same instance, then they must be equal.
That is, each interface is equal to it's instance + a specific Delta (the Delta depeneds on the interface). In other words, Interface = Instace + Delta. If 'Instance' is the same for both interfaces, and the 'Delta' is the same (cause they are of the same interface type), then both interfaces must be equal.

Note : This is the way delphi works, for good and for bad. You should take this in mind when writing code for propertys of interface type. The following code wouldn't work properly :

TSample = class
private
  FData: IUnknown;
  procedure SetData(Value: IUnknown);
protected
  procedure Changed; virtual; abstract;
public
  property Data: IUnknown read FData write SetData;
end;

procedure TSample.SetData(Value: IUnknown);
begin
  // This is incorrect.
  if Value <> FData then
  begin
    FData := Value;
    Changed;
  end;
end;

It might seem that this code should work, but it might not work when someone would assgin the property 'Data' with an IUnknown retreived by a type cast. The correct code should be :

procedure TSample.SetData(Value: IUnknown);
begin
  if (Value as IUnknown) <> (FData as IUnknown) then
  begin
    FData := Value;
    Changed;
  end;
end;

Second, each interface you declare that a class implements (with exception of interfaces that inherite from other interfaces) means that each instance of that class will take up 4 more byte of memory. That might seem like nothing (and probably is) except for one case. Consider the following code :

IInterfaceA = interface
end;

IInterfaceB = interface
end;

TSampleClass1 = class(TInterfacedObject, IInterfaceA)
end;

TSampleClass2 = class(TSampleClass1, IInterfaceA, IInterfaceB)
end;

It would seem that each instance of TSampleClass1 should take up 16 bytes, and each instance of TSampleClass2 should take up 20 bytes (4 bytes more, because it supports one more interface). That is not true. Each instance of TSampleClass1 does take up 16 byte. But, each instance of TSampleClass2 takes up 24 bytes ! That's because delphi creates an interface entry even for interfaces that are already implemented by parent classes.
The solution to this is simple. Just remove the decleration of IInterfaceA from TSampleClass2. This will not change the fact that TSampleClass2 implements IInterfaceA, cause TSamlpeClass2 inherites from TSamlpeClass1, which implements IInterface1. This wouldn't have happened if IInterfaceB was a decendant of IInterfaceA.
  
This might add up to quit alot if you do your inheritence improporely. For example :

TSampleClass1 = class(TInterfacedObject, IUnknown)
end;

TSampleClass2 = class(TSampleClass1, IUnknown)
end;

TSampleClass3 = class(TSampleClass2, IUnknown)
end;

TSampleClass4 = class(TSampleClass3, IUnknown)
end;

TSampleClass5 = class(TSampleClass4, IUnknown)
end;

Each instance of TSampleClass5 takes up 32 bytes of memory, though it has no real data (except for FRefCount of TItnerfacedObject).

How to assign multiple TEdit fields to variables

Problem/Question/Abstract:

Is there an easier way to assign multiple Edit fields to variables without individually setting each one? Here is a sample code.

type
  testrec = record
    fees: array[1..10] of string[65];
  end;

var
  dat: testrec;

procedure FormToDat;
begin
  fees[1] := Edit1.Text;
  fees[2] := Edit2.Text;
  fees[3] := Edit3.Text;
  fees[4] := Edit4.Text;
  { ... }
end;

This sample code seems inefficient and I'm thinking there might be an easier way to do this.

Answer:

There are a wide variety of ways to do this in Delphi, here's one:

var
  I: Integer;
  C: TComponent;
begin
  for I := 1 to 10 do
  begin
    C := FindComponent('Edit' + IntToStr(I));
    if C is TEdit then
      TEdit(C).Text := Fees[1];
  end;
end;

You could also store references to the edits in a TList or an array, or you could also iterate through the Controls or Components properties.

Enabling a horizontal scrollbar in a TListBox

Problem/Question/Abstract:

Enabling a horizontal scrollbar in a TListBox

Answer:

Solve 1:

There is no such property in TListBox. To force a listbox to have horizontal scrollbars, use the message LB_SETHORIZONTALEXTENT.

// e.g. in FormCreate(..)
begin
  ListBox1.Width := 300;
  // listbox can be scrolled by 100 pixels horizontally now:
  SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, 400, 0);
end;


Solve 2:

MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
  if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
    MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth + 100, 0);

It uses the Messages .dcu.

Capturing all of the Output from a Console application (16 bit)

Problem/Question/Abstract:

In my article "Capturing all of the Output from a Console application (32 bit)" posted a function for retrieving all of the output of a console application. Unfortunately, though it worked fine on 32-bit apps it did not work well with 16-bit apps. This was not a problem with the code, but rather a bug in Windows (http://support.microsoft.com/support/kb/articles/Q150/9/56.ASP). But how can this be done?

Answer:

Here is new function I have been working on which seems to do the trick.  It bypasses the problem with 16-bit apps by directing windows to send the output to a text file, and then reads it back in, deletes the file, and sends the result back to you.  Be careful when calling this with command.com.  Because it waits on the process infinitely it will hang on this because command.com waits for user input...

Special thanks to Theo Bebekis for his help on this.

If you have questions or comments please email me  at johnwlong@characterlink.net, I have not had a chance to thoroughly test this version so any feed back would be helpful.

function GetConsoleOutput(const CommandLine: string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutFile, AppProcess, AppThread: THandle;
  RootDir, WorkDir, StdOutFileName: string;
const
  FUNC_NAME = 'GetConsoleOuput';
begin
  try
    StdOutFile := 0;
    AppProcess := 0;
    AppThread := 0;
    Result := '';

    // Initialize dirs
    RootDir := ExtractFilePath(ParamStr(0));
    WorkDir := ExtractFilePath(CommandLine);

    // Check WorkDir
    if not (FileSearch(ExtractFileName(CommandLine), WorkDir) <> '') then
      WorkDir := RootDir;

    // Initialize output file security attributes
    FillChar(SA, SizeOf(SA), #0);
    SA.nLength := SizeOf(SA);
    SA.lpSecurityDescriptor := nil;
    SA.bInheritHandle := True;

    // Create Output File
    StdOutFileName := RootDir + 'output.tmp';
    StdOutFile := CreateFile(PChar(StdOutFileName),
      GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE,
      @SA,
      CREATE_ALWAYS, // Always create it
      FILE_ATTRIBUTE_TEMPORARY or // Will cache in memory
      // if possible
      FILE_FLAG_WRITE_THROUGH,
      0);

    // Check Output Handle
    if StdOutFile = INVALID_HANDLE_VALUE then
      raise Exception.CreateFmt('Function %s() failed!' + #10#13 +
        'Command line = %s', [FUNC_NAME, CommandLine]);

    // Initialize Startup Info
    FillChar(SI, SizeOf(SI), #0);
    with SI do
    begin
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE);
      hStdError := StdOutFile;
      hStdOutput := StdOutFile;
    end;

    // Create the process
    if CreateProcess(nil, PChar(CommandLine), nil, nil,
      True, 0, nil,
      PChar(WorkDir), SI, PI) then
    begin
      WaitForSingleObject(PI.hProcess, INFINITE);
      AppProcess := PI.hProcess;
      AppThread := PI.hThread;
    end
    else
      raise Exception.CreateFmt('CreateProcess() in function %s() failed!'
        + #10#13 + 'Command line = %s', [FUNC_NAME, CommandLine]);

    CloseHandle(StdOutFile);
    StdOutFile := 0;

    with TStringList.Create do
    try
      LoadFromFile(StdOutFileName);
      Result := Text;
    finally
      Free;
    end;

  finally
    // Close handles
    if StdOutFile <> 0 then
      CloseHandle(StdOutFile);
    if AppProcess <> 0 then
      CloseHandle(AppProcess);
    if AppThread <> 0 then
      CloseHandle(AppThread);

    // Delete Output file
    if FileExists(StdOutFileName) then
      DeleteFile(StdOutFileName);
  end;

end;

Load a bitmap and palette from a resource file

Problem/Question/Abstract:

Load a bitmap and palette from a resource file

Answer:

This routine loads a bitmap from a resource file and gets its palette and bitmap handle:


procedure LoadBitmapPalette(szTitle: PChar; var hPal: HPalette;
  var hBitmap: HBitmap);
type
  TMLogPalette = record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: array[0..255] of TPaletteEntry;
  end;
var
  hOldPal: HPALETTE;
  pPal: TMLogPalette;
  dc: hDC; { device context for palette }
  hRes: THandle; { resource handle for bitmap }
  pBits: PBITMAPINFOHEADER; { pointer to bitmapinfoheader
  in resource }
  pRgb: ^TRGBQUAD; { Zeiger auf DIB-Palettendaten }
  i: integer;
  Data: PChar;
begin
  hRes := FindResource(hInstance, szTitle, RT_BITMAP);
  if hRes <> 0 then
    hRes := LoadResource(hInstance, hRes);

  if hRes <> 0 then
  begin
    pBits := PBITMAPINFOHEADER(LockResource(hRes));

    { so: having 16 colors, we do not need a palette
      (LoadBitmap is allright)
      > 256 colors: no palette is needed ("hi-/direct/true color")  }

    if (pBits^.biBitCount <= 8) and { only for <= 256 color bitmaps }
    (pBits^.biSize =
      sizeof(TBITMAPINFOHEADER)) { only Windows-bitmaps, not OS/2 } then
    begin
      pRgb := pointer(pBits);
      inc(PChar(pRgb), pBits^.biSize);

      pPal.palNumEntries := 1 shl pBits^.biBitCount;
      pPal.palVersion := $300;

      for i := 0 to pPal.palNumEntries - 1 do
      begin
        pPal.palPalEntry[i].peRed := pRgb^.rgbRed;
        pPal.palPalEntry[i].peGreen := pRgb^.rgbGreen;
        pPal.palPalEntry[i].peBlue := pRgb^.rgbBlue;
        pPal.palPalEntry[i].peFlags := 0 {PC_NOCOLLAPSE};
        inc(PChar(pRgb), 4);
      end;

      hPal := CreatePalette(PLogPalette(@pPal)^);

      DC := GetDC(0);

      hOldPal := SelectPalette(DC, hPal, false);
      RealizePalette(DC);

      with pBits^ do
      begin
        biClrImportant := 0;
        biClrUsed := 0;
      end;

      Data := pointer(pBits);
      inc(Data, pBits^.biSize + pPal.palNumEntries * sizeof(TRGBQUAD));
      hBitmap := CreateDIBitmap(DC, pBits^, CBM_INIT,
        Data, PBitmapInfo(pBits)^,
        dib_RGB_Colors);

      SelectPalette(DC, hOldPal, FALSE);

      ReleaseDC(0, DC);
    end;

    UnlockResource(hRes);
  end
  else
    hBitmap := LoadBitmap(hInstance, szTitle);
end;

Change a form's caption font and alignment

Problem/Question/Abstract:

I want to change the form's caption font and alignment to DT_CENTER. How can I do this?

Answer:

Note: The formDeactivate never gets called so when the form isn't active, sometimes the FormPaint isn't called. If anything causes the form to be repainted while in inactive, it draws correctly.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
var
  LabelHeight, LabelWidth, LabelTop: Integer;
  caption_height, border3d_y, button_width, border_thickness: Integer;
  MyCanvas: TCanvas;
  CaptionBarRect: TRect;
begin
  CaptionBarRect := Rect(0, 0, 0, 0);
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(Form1.Handle);
  border3d_y := GetSystemMetrics(SM_CYEDGE);
  button_width := GetSystemMetrics(SM_CXSIZE);
  border_thickness := GetSystemMetrics(SM_CYSIZEFRAME);
  caption_height := GetSystemMetrics(SM_CYCAPTION);
  LabelWidth := Form1.Canvas.TextWidth(Form1.Caption);
  LabelHeight := Form1.Canvas.TextHeight(Form1.Caption);
  LabelTop := LabelHeight - (caption_height div 2);
  CaptionBarRect.Left := border_thickness + border3d_y + button_width;
  CaptionBarRect.Right := Form1.Width - (border_thickness + border3d_y)
                - (button_width * 4);
  CaptionBarRect.Top := border_thickness + border3d_y;
  CaptionBarRect.Bottom := caption_height;
  if Form1.Active then
    MyCanvas.Brush.Color := clActiveCaption
  else
    MyCanvas.Brush.Color := clInActiveCaption;
  MyCanvas.Brush.Style := bsSolid;
  MyCanvas.FillRect(CaptionBarRect);
  MyCanvas.Brush.Style := bsClear;
  MyCanvas.Font.Color := clCaptionText;
  MyCanvas.Font.Name := 'MS Sans Serif';
  MyCanvas.Font.Style := MyCanvas.Font.Style + [fsBold];
  DrawText(MyCanvas.Handle, PChar(' ' + Form1.Caption), Length(Form1.Caption) + 1,
    CaptionBarRect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
  MyCanvas.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Form1.Paint;
end;

end.

Get a TForm's normal bounding rectangle

Problem/Question/Abstract:

I'm trying to find out where a TForm stores its original values for top, left, height and width of the form when it is maximizing. It must be stored somewhere because when I click on restore it goes to its original position and size.

Answer:

Call the GetWindowPlacement function, passing the form's Handle property as the window handle. Here's a sample function that gets a form's normal bounding rectangle:

function GetFormNormalRect(Form: TCustomForm): TRect;
var
  Placement: TWindowPlacement;
begin
  Placement.length := SizeOf(Placement);
  if not GetWindowPlacement(Form.Handle, @Placement) then
    RaiseLastWin32Error;
  Result := Placement.rcNormalPosition;
end;

OLE Error: CoInitialize has not been called

Problem/Question/Abstract:

OLE Error: CoInitialize has not been called

Answer:

In a project that needed to display HTML documents, I decided to use the TWebBrowser control. I had used this handy ActiveX control successfully in other projects before.

This application was an MDI application, written in Delphi 5. As a 'specialty' I had installed a beta version of Internet Explorer on my system. I am not sure which of this is responsible for it, but when I would call the function in my application to display the HTML document, the TWebBrowser element could not be instantiated.
Instead I would receive an error message:

'CoInitialize has not been called'

The surprising thing is that the webbrowser control shows fine in design mode! I checked and TWebBrowser was properly installed. The underlieing DLL was also registered properly. A call of

regsvr32 shdocvw.dll

did not help. Finally I manually called the CoInitialize() function. I had to add OLE2 to the list of used units. A good place to do this is the initialization part as the sample snippet below shows.


uses
  OLE2, // <-- make sure to include this unit
  Windows; // and others

initialization
  CoInitialize(nil); // <-- manually call CoInitialize()

end.

How to create a lookup table

Problem/Question/Abstract:

I have written some code for creating a table and I also want to specify a lookup table for a some fields. What's the code for that?

Answer:

var
  f: TField;
  i: integer;
begin
  table1.FieldDefs.Update
    table1.Close;
  for i := 0 to table1.FieldDefs.Count - 1 do
    if table1.FindField(Query.FieldDefs[i].Name) = nil then
      {persistent field does not exist}
      table1.FieldDefs.Items[i].CreateField(table1);
  f := TStringField.Create(table1);
  f.Name := 'table1lookup';
  f.FieldName := 'lookup';
  f.DisplayLabel := 'lookup';
  f.fieldType := fklookup;
  f.Calculated := True;
  f.DataSet := table1;
  f.lookupDataSet := table2;
  f.Keyfields := 'Keyfield1';
  f.Lookupfields := 'Keyfield1';
  f.LookupResultField := 'ResultField';
  table1.Open;
end;

How to copy text from a TRichEdit to the canvas of a TImage

Problem/Question/Abstract:

How to copy text from a TRichEdit to the canvas of a TImage

Answer:

uses
  Richedit;

var
  imagecanvas: TCanvas;
  fmt: TFormatRange;
begin
  imagecanvas := image1.canvas;
  with fmt do
  begin
    hdc := imagecanvas.handle;
    hdcTarget := hdc;
    rc := Rect(0, 0, imagecanvas.cliprect.right * 1440 div pixelsperinch,
      imagecanvas.cliprect.bottom * 1440 div pixelsperinch);
    rcPage := rc;
    chrg.cpMin := 0;
    chrg.cpMax := richedit1.GetTextLen;
  end;
  {  SetBkMode( imagecanvas.Handle, TRANSPARENT );  }
  richedit1.perform(EM_FORMATRANGE, 1, integer(@fmt));
  richedit1.perform(EM_FORMATRANGE, 0, 0);
  image1.refresh;
end;

Streaming Components

Problem/Question/Abstract:

Saving and loading Component Published Propertys to disk

Answer:

The TStreams Class has a nice feature Couse it can stream component propertys in just one line .

So here's the complete unit where i Stream the component
If your class is not in the same unit you will have to register it .

{
procedure RegisterClasses(AClasses: array of TPersistentClass);

Description

Call RegisterClasses to register a set of custom classes in a single line. Each class is registered by calling RegisterClass. Unregistered classes can&#8217;t be loaded or saved by the VCL streaming system.
}

unit Unit1;

interface

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

type
  // jus a enumeration
  TSomeints = 1..10;
  // set of the enumeration
  TExampleSet = set of TSomeints;
  TExampleComponent = class(TComponent)
  private
    FASet: TExampleSet;
    FAString: string;
    FAFloat: Double;
    FAInteger: Integer;
  published
    // Anyting you want streamed and is streameble by Delphi you can publish
    // as property
    property AString: string read FAString write FAString;
    property ASet: TExampleSet read FASet write FASet;
    property AInteger: Integer read FAInteger write FAInteger;
    property AFloat: Double read FAFloat write FAFloat;
  end;

  TForm1 = class(TForm)
    SaveToStream: TButton;
    LoadFromStream: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    EAFloat: TEdit;
    EAstring: TEdit;
    procedure SaveToStreamClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure LoadFromStreamClick(Sender: TObject);
  private
    FExampleComponent: TExampleComponent;
    procedure SetExampleComponent(const Value: TExampleComponent);
    { Private declarations }
  public
    property ExampleComponent: TExampleComponent read FExampleComponent write
      SetExampleComponent;
    procedure ObjectToGui;
    procedure GuiToObject;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SaveToStreamClick(Sender: TObject);
var
  AStream: TMemoryStream;
begin
  if SaveDialog1.execute then
  begin
    GuiToObject;
    AStream := TMemoryStream.Create;
    try
      AStream.WriteComponent(ExampleComponent);
      AStream.SaveToFile(SaveDialog1.FileName);
    finally
      AStream.free;
    end;
  end;
end;

procedure TForm1.SetExampleComponent(const Value: TExampleComponent);
begin
  FExampleComponent := Value;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // this is the Procedure To Call if you want to Use components not defined
  // in this unit ;
  // RegisterClasses([TButton,TMemo,TEnz]);
  FExampleComponent := TExampleComponent.Create(Self);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FExampleComponent.free;
end;

procedure TForm1.LoadFromStreamClick(Sender: TObject);

var
  AStream: TMemoryStream;
begin
  if OpenDialog1.execute then
  begin
    AStream := TMemoryStream.Create;
    try
      AStream.LoadFromFile(OpenDialog1.FileName);
      AStream.ReadComponent(ExampleComponent);
      ObjectToGui;
    finally
      AStream.free;
    end;
  end;
end;

procedure TForm1.GuiToObject;
begin
  ExampleComponent.AString := EAstring.Text;
  ExampleComponent.AFloat := StrToFloat(EAFloat.Text);
end;

procedure TForm1.ObjectToGui;
begin
  EAstring.Text := ExampleComponent.AString;
  EAFloat.Text := FloatToStr(ExampleComponent.AFloat);
end;

end.

Component Download: http://www.xs4all.nl/~suusie/Pieter/Programs/StreamingComponent.zip

How to store the contents of a TRichEdit into a Paradox blob field while maintaining formatting

Problem/Question/Abstract:

How to store the contents of a TRichEdit into a Paradox blob field while maintaining formatting

Answer:

Table1.fieldbyName('YourBlobField').assign(richedit1.lines)

How to create a submenu at runtime

Problem/Question/Abstract:

I have a menu item in a menu and would like to fill a submenu with items loaded at runtime.

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  aItem, aSubItem: TMenuItem;
  i, j: integer;
begin
  with MenuItem1 do {is an existing MenuItem}
  begin
    for i := 0 to 5 do
    begin
      aItem := TMenuItem.Create(MainMenu1);
      Add(aItem);
      aItem.Caption := IntToStr(i);
      for j := 0 to 5 do
      begin
        aSubItem := TMenuItem.Create(MainMenu1);
        aItem.Add(aSubItem);
        aSubItem.Caption := IntToStr(j);
        aSubItem.OnClick := MenuItemsHandler;
      end;
    end;
  end;
end;

procedure TForm1.MenuItemsHandler(Sender: TObject);
begin
  ShowMessage((Sender as TMenuItem).Caption);
end;

Adding an url to Browser/Windows Favorite

Problem/Question/Abstract:

How to add an url to Browser/Windows Favorite

Answer:

Note. I've made this example for complete beginner.
Jump to the code if you don't need any explanation. There no API manipulation here, we place manually the shortcut in the the folder.

Here's how you can add an url in you favorite. This work for any browser, except if they use special data type to store their url library. The only example I see of an application that use another type of data is the utility LinkMan wich is, anyway, not a browser application.

Basicly, to create a shortcut url all you need to know is the structure of this file type. You need also to know a little about file manipulation, if you don't, this example will serve also as a guide for very simple file manipulation.

First put 3 TEdit component on your form and add TButton component.
Add three label to identify you EditBox. First EditBox should be associate with Folder, the second with URL and the last with Title.

Folder -  Will store the access path to your browser favorite folder
URL - Will store the URL (Http, www, etc)
Title - Is the name you give to the URL (Yahoo, Baltsoft)

For the AddUrl procedure to work, you need to pass it these three paramater as string. To do so affect your .Text property of your TEdit Component to your own variables.

If you are new to Delphi you will find pretty interesting the output to file part where I use AssignFile, ReWrite, WriteLn... I suggest you try some of you own app using those command to test results with your own value.  

I included also a small line that can create a folder if the folder don't exist. This is a proper to the use of FileCtrl. Also of interest the small handling of \ if it's not present for lazy user.

Don't change you components name, it will be easier to follow the code.

Here we go..

unit MyUnit;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure AddUrl(Folder, Url, Title: string);
  end;

var
  Form1: TForm1;
  MyFolder: string;
  MyUrl: string;
  MyTitle: string;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyFolder := Edit1.Text;
  MyURL := Edit2.Text;
  MyTitle := Edit3.Text;
  AddUrl(MyFolder, MyUrl, MyTiTle);
end;

procedure TForm1.AddURL(Folder, Url, Title: string);
var
  MyUrlFile: TextFile;
begin
  if Folder[Length(Folder)] <> '\' then
    Folder := Folder + '\';
  if not DirectoryExists(Folder) then
    ForceDirectories(Folder);
  try
    AssignFile(MyUrlFile, Folder + title + '.url');
    Rewrite(MyUrlFile);
    WriteLn(MyUrlFile, '[InternetShortcut]');
    WriteLn(MyUrlFile, 'URL=' + url);
  finally
    Closefile(MyUrlFile);
  end;
end;

end.

Change the position of a list item in a TListView

Problem/Question/Abstract:

How can I move a list item of a TListView one postion down or up?

Answer:

var
  item: TListItem;
begin
  with lvlist do
  begin
    {preserve item since currentPos will be invalid after next line}
    item := items[currentPos];
    {make a new item and assign to it}
    items.insert(moveToPos).assign(item);
    {old item will now remove itself from the listview}
    item.delete;
  end;
end;

Check if the BDE is installed

Problem/Question/Abstract:

I want to run the BDE install from my own setup application. Before I run the BDE installation, I would like to check that BDE is installed.

Answer:

Solve 1:

function isbdepresent: boolean;
var
  IdapiPath: array[0..255] of Char;
  IdapiHandle: THandle;
begin
  result := false;
  GetProfileString('IDAPI', 'DLLPath', 'C:\', IdapiPath, 255);
  {next lines isolates the first directory path from the IdapiPath in case
        there are more}
  if Pos(';', StrPas(IdapiPath)) <> 0 then
  begin
    StrPCopy(IdapiPath, Copy(StrPas(IdapiPath), 1, Pred(Pos(';',
      StrPas(IdapiPath)))));
  end;
  IdapiHandle := LoadLibrary(StrCat(IdapiPath, '\IDAPI01.DLL'));
  if IdapiHandle < HINSTANCE_ERROR then
    result := false
      {IDAPI is not present on this system}
  else
  begin
    FreeLibrary(IdapiHandle);
    result := true;
    {IDAPI is present on this system}
  end;
end;


Solve 2:

Try to check the registry for the presence of the BDE:

with TRegistry.create do
begin
  Rootkey := HKEY_LOCAL_MACHINE;
  OpenKey('SOFTWARE\BORLAND\DATABASE ENGINE', false);
  CFGFile := ReadString('CONFIGFILE01');
  Free;
end;


Solve 3:

you can try to initialize the BDE

IsBDEExist := (dbiInit(nil) = 0)

How to change the button caption in a TOpenDialog

Problem/Question/Abstract:

I need a dialog for the user to select files to delete. The TOpenDialog works just fine except that the button says Open, and I need it to say Delete.

Answer:

You will need to include Commdlg in your uses clause. In the TOpenDialog.OnShow event:

procedure TForm1.OpenDialog1Show(Sender: TObject);
begin
  SendMessage(GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, 1,
    Integer(PChar('Delete')));
end;

TCheckListBox LoadFromFile/SaveToFile Method, included checked state?

Problem/Question/Abstract:

What to use the TCheckListBox LoadFromFile and SaveToFile Method, and store the checked state at the same time?

Answer:

If you embed the Checked property into the actual entry as a &#8220;1&#8221; or &#8220;0&#8221; charter you can save the file with the normal SaveToFile method. When a file is loaded using the LoadFromFile method as normal.  Then extract the first charter from the entry and you will have the checked state.

{====================================}

procedure TFrameRuleEngine.SaveRules;
{====================================}
var
  i: Integer;

begin
  i := 0;
  while i < CheckListBoxRule.Items.Count do
  begin
    if CheckListBoxRule.Items[i] = '' then
    begin
      // Delete entry it is empty
      CheckListBoxRule.Items.Delete(i);
    end
    else
    begin
      // Add a 1 or 0 as the first charter in the entry for checked or not checked
      CheckListBoxRule.Items[i] := IntToStr(Integer(CheckListBoxRule.Checked[i])) +
        CheckListBoxRule.Items[i];
      Inc(i);
    end;
  end;
  // Save the full list as normal
  CheckListBoxRule.Items.SaveToFile(ExtractFilePath(Application.ExeName) +
    'Rule.Txt');
end;

{===================================}

procedure TFrameRuleEngine.LoadRules;
{===================================}
var
  sChecked: string;
  i: Integer;

begin
  if FileExists(ExtractFilePath(Application.ExeName) + 'Rule.Txt') then
  begin
    // Read the file as normal
    CheckListBoxRule.Items.LoadFromFile(ExtractFilePath(Application.ExeName) +
      'Rule.Txt');
    i := 0;
    while i < CheckListBoxRule.Items.Count do
    begin
      if CheckListBoxRule.Items[i] = '' then
      begin
        // Delete an empty entry
        CheckListBoxRule.Items.Delete(i);
      end
      else
      begin
        // Get the checked state
        sChecked := Copy(CheckListBoxRule.Items[i], 1, 1);
        CheckListBoxRule.Items[i] := Copy(CheckListBoxRule.Items[i], 2,
          Length(CheckListBoxRule.Items[i]));
        // Update the Checked property
        CheckListBoxRule.Checked[i] := Boolean(StrToInt(sChecked));
        Inc(i);
      end;
    end;
  end;
end;

Reporting file size in a descriptive string

Problem/Question/Abstract:

How to tell the file size in a descriptive string like "2.33MB", or "233 bytes", as Windows Explorer does in a status bar?

Answer:

The articles of Adam Lanzafame and NYB about file size string, and follow-up discussions inspired me to come with a solution which would resolve some of the issues of both aforementioned approaches/implementations (see the DPFileSize unit attached below).

Some of these issues are:

Adam's function depends on the external library presence, specifically SHLWAPI.DLL (Shell Light-weight Utility Library), which is essentially a helper library and may not be installed on all systems.

For files from 1000 to 1023 bytes in size both Adam's and NYB's functions return the size in bytes, while Windows Explorer displays '0.99KB'

Windows Explorer doesn't add space between a number and 'KB', 'MB', and 'GB', while both Adam's and NYB's functions do.

NYB's function always displays two digits after a decimal point (even for bytes), while the main idea of how Windows Explorer represents the number here is obviously to keep three significant digits, including leading zero before decimal point (see item 2 above)  

NYB's function rounds the resulting value to the nearest value of the least significant digit. The Windows Explorer approach seems to me as more consistent - we may accept either one of the rounding directions, but it is better to be fixed. The direction used by Explorer is towards lesser value of the least significant digit, so it consistently shows that a file is at least of indicated size.

All these issues have been addressed in the unit below.

//******************************************************************************
//
// Unit Name: DPFileSize
// Purpose  : Functions for reporting file size with a descriptive string
// Author   : (c) 2001 Dmitri Papichev {Dmitri.Papichev@iname.com}
// Comments : Specially for www.delphi3000.com
//
//******************************************************************************

unit DPFileSize;

{==============================================================================}
interface

const
  KB = 1024;
  MB = KB * KB;
  GB = MB * KB;

  {main function}
function GetFileSizeString(const AFileName: string): string;

{helper functions, surfaced here as they might be used on their own}
function DPGetFileSize(const AFileName: string): integer;
function GetSignificantDigits(const ARealNumber: double;
  const ADigits: integer): string;
function FormatFileSizeValue(const AValue: integer): string;

{==============================================================================}
implementation
uses
  SysUtils,
  Classes;

{------------------------------------------------------------------------------}
{returns the string representing the file size for a given filename, in a way
similar to what Windows Explorer does}

function GetFileSizeString(const AFileName: string): string;
begin
  try
    Result := FormatFileSizeValue(DPGetFileSize(AFileName));
  except
    on E: Exception do
    begin
      Result := E.Message;
    end; {on}
  end; {if}
end; {--GetFileSizeString--}

{------------------------------------------------------------------------------}
{returns file size in bytes for a given filename}

function DPGetFileSize(const AFileName: string): integer;
var
  AFileStream: TFileStream;
begin
  AFileStream := TFileStream.Create(AFileName,
    fmShareCompat or fmShareDenyNone);
  try
    Result := AFileStream.Size;
  finally
    AFileStream.Free;
  end; {try}
end; {--GetFileSizeDP--}

{------------------------------------------------------------------------------}
{returns first ADigits significant digits of ARealNumber,
with a decimal point if any}

function GetSignificantDigits(const ARealNumber: double;
  const ADigits: integer): string;
begin
  if ADigits in [1..16] then
  begin {that's the range of sig. digits supported}
    Result := Format('%' +
      IntToStr(ADigits) + '.' +
      IntToStr(ADigits) + 'f', [ARealNumber]);

    Result := Copy(Result, 1, ADigits + 1);
    if (Pos('.', Result) in [0, ADigits + 1]) then
    begin
      Result := Copy(Result, 1, ADigits);
    end; {if}
  end
  else
  begin
    raise Exception.Create('GetSignificantDigits: ' +
      'A number of significant digits out of range');
  end; {if}
end; {--GetSignificantDigits--}

{------------------------------------------------------------------------}
{converts given AValue to the string representing file size, in a way similar
to what Windows Explorer does}

function FormatFileSizeValue(const AValue: integer): string;
begin
  case AValue of
    0..999:
      begin
        Result := IntToStr(AValue) + ' bytes';
      end;
    1000..(MB - 1):
      begin
        Result := GetSignificantDigits(AValue / KB, 3) + 'KB';
      end;
    MB..(GB - 1):
      begin
        Result := GetSignificantDigits(AValue / MB, 3) + 'MB';
      end;
  else
    begin
      Result := GetSignificantDigits(AValue / GB, 3) + 'GB';
    end;
  end; {case}
end; {--FormatFileSizeValue--}

end.

Change the primary mouse button

Problem/Question/Abstract:

How do you change the primary mouse button

Answer:

To change the primary mouse button in code you need to execute an API function called SwapMouseButton. This changes the primary button but does not alert the control panel applet for the mouse that the primary button has changed. To do this we need to write to the registry. The code below shows how to toggle the primary mouse button by first reading the registry to determine the current assignment then does the toggle by writing to the registry and executing the SwapMouseButton function.

uses Windows, Registry;

const
  LeftButton = '0';
  RightButton = '1';
  VaueToRead = 'SwapMouseButtons';
begin
  with TRegistry.Create do
  begin
    try
      if OpenKey('Control Panel\Mouse', False) then
      begin
        if ValueExists(VaueToRead) then
          if ReadString(VaueToRead) = LeftButton then
          begin
            SwapMouseButton(True);
            WriteString(VaueToRead, RightButton);
          end
          else
          begin
            SwapMouseButton(False);
            WriteString(VaueToRead, LeftButton);
          end;
        CloseKey;
      end;
    finally
      Free;
    end;
  end;
end.

How to change the highlight colour in a TDBGrid

Problem/Question/Abstract:

How to change the highlight colour in a TDBGrid

Answer:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if gdSelected in State then
    DBGrid1.Canvas.Brush.Color := clLime;
  DBGrid1.DefaultDrawDataCell(Rect, Field, State);
end;


or use the OnDrawColumnCell method like this:


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  inherited;
  with (Sender as TDBGrid) do
  begin
    if gdSelected in State then
    begin
      Canvas.Font.Style := [fsBold];
      Canvas.Font.Color := clRed;
      Canvas.Brush.Color := clYellow;
      DefaultDrawColumnCell(Rect, DataCol, Column, State);
    end;
  end;
end;

How to register an OCX

Problem/Question/Abstract:

How to register an OCX

Answer:

Your installation program needs to register an OCX, but doesn't support this? Or you want to
register it by your program yourself?

Suppose the OCX you want to use is called


program RegisterMyOCX;
uses
  OLECtl, Windows, Dialogs;
var
  OCXHand: THandle;
  RegFunc: TDllRegisterServer; //add  to the uses clause
begin
  OCXHand := LoadLibrary('c:\windows\system\test.ocx');
  RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer'); //case sensitive
  if RegFunc <> 0 then
    RegFunc
  else
    ShowMessage('Error!');
  FreeLibrary(OCXHand);

  // You can the same way unregister the OCX:
  // replace 'DllRegisterServer' by 'DllUnregisterServer'
end.

Display a sort order indicator in the column header of a TListView (2)

Problem/Question/Abstract:

Does anyone know how to add custom painting to the column headings in vsReport mode (short of ownerdrawing everything)? I'd like to add indication of sort order and more. I don't think the columns ImageIndex is a satisfactory solution. I would like the image of the sort indicator on the right.

Answer:

The problem is that not all versions of the listview common control support this. You have to drop to the API to make use of it. This is somewhat ackward (the common controls seem to get more cumbersome to use with each version). The listviews header line is an actual header control. A header control can display either images from an imagelist or a bitmap. Only the bitmap can be arranged to the right of the caption text. The listview offers no direct method to set a bitmap for a header, so you have to get the header controls handle and send messages to it directly. The bitmap you use should be created on form creation and destroyed on form destruction.

The following example shows the principle. There is a major snag here, though. Since the VCL listview has no idea that you changed some header properties it will happily wipe out what you did every time it feels like resetting some of the header properties, e.g. when the user resizes one of the columns. This can be dealt with if needs be, by subclassing the header control to trap the HDM_SETITEM messages that change the item properties. The TListview class already subclasses the header but the method used is private and not virtual, so not accessible.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListView1: TListView;
    ImageList1: TImageList;
    procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FUpArrow, FDownArrow: TBitmap;
    procedure SetColumnSortOrder(lv: TListview; Column: TListcolumn);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  commctrl;

{$R *.DFM}

procedure TForm1.SetColumnSortOrder(lv: TListview; Column: TListcolumn);
var
  hdr: HWND;
  hdritem: THDItem;
begin
  hdr := Listview_GetHeader(lv.handle);
  FillChar(hdritem, sizeof(hdritem), 0);
  hdritem.Mask := HDI_FORMAT;
  Header_GetItem(hdr, column.index, hdritem);
  hdritem.Mask := HDI_FORMAT or HDI_BITMAP;
  if column.tag = 0 then
    hdritem.hbm := FUpArrow.Handle
  else
    hdritem.hbm := FDownArrow.Handle;
  hdritem.fmt := hdritem.fmt or HDF_BITMAP_ON_RIGHT or HDF_BITMAP;
  Header_SetItem(hdr, column.index, hdritem);
end;

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  Column.Tag := Ord(not Odd(Column.Tag));
  SetColumnSortOrder(Sender as TListview, Column);
end;

procedure TForm1.FormCreate(Sender: TObject);

  procedure MakeBitmap(var bmp: TBitmap; imageindex: Integer);
  begin
    bmp := TBitmap.Create;
    bmp.Width := imagelist1.width;
    bmp.Height := imagelist1.height;
    with bmp.Canvas do
    begin
      Brush.Color := clBtnface;
      Brush.Style := bsSolid;
      FillRect(Cliprect);
    end;
    imagelist1.Draw(bmp.canvas, 0, 0, imageindex);
  end;

begin
  MakeBitmap(FUpArrow, 1);
  MakeBitmap(FDownArrow, 0);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FUpArrow.Free;
  FDownArrow.Free;
end;

end.

Change the alignment for TEdit

Problem/Question/Abstract:

How can I change the alignment for my TEdit?

Answer:

Sometimes you need change the text alignment in standard TEdit component. For some reason the developers in Microsoft decided, that for data editing in single line we do not need to change alignment and haven't provided such possibility:(

But sometimes I need it! For example, I like view a numbers with right alignment...

If you need it too then this delphi tip for you:

type
  TEditAlignment = class(TCustomEdit)
  protected
    { Protected declarations }
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TEditAlignment.CreateParams(var Params: TCreateParams);
const
  Alignments: array[TAlignment] of Longint =
  (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
  inherited CreateParams(Params);

  Params.Style := Params.Style or ES_MULTILINE or
    Alignments[FAlignment];
end;

In Windows 98 you can set a Params.Style without ES_MULTILINE flag and it too will work.

Also after such edit control can't correctly work with PasswordChar <> #0 (but I think for password input it's not necessary to change alignment).

PS: remark, that after that your TEdit is not "real" edit control - now is a control like "memo" but single line... Of course, you can use a standard TMemo component with height equal to one line.

Component Download: http://www.geocities.com/mshkolnik/download/edittype.zip

How to set a string or integer property for a component if it exists

Problem/Question/Abstract:

I am building a routine that checks our forms for validity before deploying them. I would like to use some kind of structure that tests if a component type has access to a certain property, something like: " if (self.Controls[b] has Tag) then ...". Can anyone offer suggestions?

Answer:

Here's an example of setting a string property for a component if it exists and another for an integer property:

procedure SetStringPropertyIfExists(AComp: TComponent; APropName: string;
  AValue: string);
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
      SetStrProp(AComp, PropInfo, AValue);
  end;
end;

procedure SetIntegerPropertyIfExists(AComp: TComponent; APropName: string;
  AValue: Integer);
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    if PropInfo^.PropType^.Kind = tkInteger then
      SetOrdProp(AComp, PropInfo, AValue);
  end;
end;

How to really add a form to a DLL

Problem/Question/Abstract:

Adding a form to a DLL is actually quite simple. Depending on the type of form (modal or mode-less) you have to proceed differently. This article explains how it is done.

Answer:

To add a form to a DLL you have to remember these things:

assign the calling programs Application.Handle to the DLL's Application.Handle
write one or two exported functions that handles the interaction with the calling program
include sharemem as the first unit in the DLL's uses clause if the exported functions uses strings
if you are going to show a mode-less form, you should return a handle to your form in the "Show" function and require it as a parameter in the "Close" function
always create the form with the Application object as the Owner
restore the DLL's Application.Handle after closing the form

You don't have to do anything special to add a form to a DLL: just add the forms filename to the uses clause and Delphi will compile it right into the DLL.

Here's an example with both modal and mode-less invocation. The examples just return an integer value, but you could of course return just about anything:

library testDLL;

uses
  myTestFrom, SysUtils, Controls;

var
  OldApphandle: longint = 0;

  { these functions are used with the mode-less form: }

  { AppHandle is the *calling* applications Handle }

function ShowTestForm(AppHandle: integer): longint;
var
  F: TmyTestForm;
begin
  { save current handle unless it's already done }
  if Application.Handle <> AppHandle then
    OldAppHandle := Application.Handle;
  { assign new }
  Application.Handle := AppHandle;
  { create and show form }
  F := TmyTestForm.Create(Application);
  F.Show;
  Result := longint(F);
end;

{ the input value, Handle, must be the same value as returned by ShowTestForm }

function CloseTestForm(Handle: longint): integer;
var
  F: TmyTestForm;
begin
  { typecast back to TForm (some sanity checks here would not be bad...}
  F := TmyTestForm(Handle);
  Result := F.SomeIntValue;
  F.Close;
  F.Free;
  { restore previous handle }
  Application.Handle := OldAppHandle;
end;

{ this function is used to show the form modally }

function ShowTestFormModal(AppHandle: integer): longint;
var
  F: TmyTestForm;
begin
  OldAppHandle := Application.Handle;
  try
    Application.Handle := AppHandle;
    F := TmyTestForm.Create(Application);
    try
      if F.ShowModal = mrOK then
        Result := F.SomeIntValue
      else
        Result := -1;
    finally
      F.Free;
    end;
  finally
    Application.Handle := OldAppHandle;
  end;
end;

{ finally export the functions: }

exports ShowTestForm name 'ShowTestForm', CloseTestForm name 'CloseTestForm',
  ShowTestFormModal name 'ShowTestFormModal';

begin
end.

How to disable a TTimer while browsing a menu

Problem/Question/Abstract:

I have an application that auto-minimizes itself after 4 seconds, when maximized (using TTimer). The main form has a menu. I want the Timer to be disabled while the user browses the menu items. Is that possible?

Answer:

Solve 1:

Add this line to your form declaration:

protected

procedure WMMenuSelect(var msg: TWMMenuSelect); message WM_MenuSelect;

and then add this procedure:

procedure TForm1.WMMenuSelect(var msg: TWMMenuSelect);
begin
  tmrAutoClose.Enabled := (msg.MenuFlag = $FFFF);
end;


Solve 2:

Yes. The form will get one special message when the menu is first opened (WM_ENTERMENULOOP) and a second when the menu is finally closed (WM_EXITMENULOOP). Add handlers for these and disable/ enable the timer in them.

{ ... }
private

procedure WMEnterMenuLoop(var msg: TMessage);
  message WM_ENTERMENULOOP;
procedure WMExitMenuLoop(var msg: TMessage);
  message WM_EXITMENULOOP;
{ ... }

procedure TForm1.WMEnterMenuLoop(var msg: TMessage);
begin
  IdleTimer.Enabled := false;
  inherited;
end;

procedure TForm1.WMExitMenuLoop(var msg: TMessage);
begin
  IdleTimer.Enabled := true;
  inherited;
end;