Create Insert Table menu like in Word using TDrawGrid component

Problem/Question/Abstract:

I think all of us know the function in MS Word which is called "Insert Table". Pressing this button there appears SubMenu window which is separated in squares - cells and columns. When we move a mouse on these squares they become active and after pressing left mouse button is create the table with the same number of cells and columns as we selected. Maybe anyone could suggest how to do this.

Answer:

The solution is

Put TDrawGrid component on Form and name it dwgTable, then property DefaultDrawing set to false.
Also configure the following properties:
DefaultColWidth to 20
DefaultRowHeight to 15
ColCount first set to 0 then 3
RowCount first set to 0 then 3
BorderStyle to bsNone
Schroolbar also to none

The code is

procedure TForm1.dwgTableMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
vCol, vRow: Integer;
begin
if (X > 0) and (y > 0) then
begin
vCol := Trunc(x / (dwgTable.DefaultColWidth + 1));
vRow := Trunc(y / (dwgTable.DefaultRowHeight + 1));
dwgTable.ColCount := vCol + 2;
dwgTable.RowCount := vRow + 2;
end;
dwgTable.Height := (dwgTable.DefaultRowHeight + 1) * dwgTable.RowCount;
dwgTable.Width := (dwgTable.DefaultColWidth + 1) * dwgTable.ColCount;
end;

procedure TForm1.dwgTableDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
vColText, vRowText: string;
RowHorzOffset, RowVertOffset,
ColHorzOffset, ColVertOffset: integer;
begin
if (dwgTable.ColCount - 1 = ACol) or (dwgTable.RowCount - 1 = ARow) then
begin
dwgTable.Canvas.Brush.Color := clInfoBk;
dwgTable.Canvas.FillRect(Rect);
vColText := Inttostr(ACol + 1);
vRowText := Inttostr(ARow + 1);
with dwgTable.Canvas do
begin
RowVertOffset := (((Rect.Bottom - Rect.Top) - TextExtent(vRowText).CY)
div 2);
RowHorzOffset := ((Rect.Right - Rect.Left) - TextExtent(vRowText).CX)
div 2;
ColVertOffset := (((Rect.Bottom - Rect.Top) - TextExtent(vColText).CY)
div 2);
ColHorzOffset := ((Rect.Right - Rect.Left) - TextExtent(vColText).CX)
div 2;
end;

if (dwgTable.ColCount - 1 <> ACol) or (dwgTable.RowCount - 1 <> ARow) then
begin
if (dwgTable.ColCount - 1 = ACol) then
dwgTable.Canvas.TextOut(Rect.Left + RowhorzOffset, Rect.Top +
RowVertOffset, vRowText);
if (dwgTable.RowCount - 1 = ARow) then
dwgTable.Canvas.TextOut(Rect.Left + ColhorzOffset, Rect.Top +
ColVertOffset, vColText);
end;
end
else
begin
dwgTable.Canvas.Brush.Color := clWindow;
dwgTable.Canvas.FillRect(Rect);
end;
end;

procedure TForm1.dwgTableClick(Sender: TObject);
begin
ShowMessage('Col:' + Inttostr(dwgTable.ColCount - 1) + '
Row: '+Inttostr(dwgTable.RowCount-1));
end;

put the TWebbrowser into Edit Mode

Problem/Question/Abstract:

put the TWebbrowser into Edit Mode

You can use the designMode property to put the Webbrowser  into a mode where you can edit the current document.

Answer:
{
You can use the designMode property to put the Webbrowser
into a mode where you can edit the current document.
}

uses
MSHTML_TLB;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
CurrentWB: IWebBrowser;
begin
CurrentWB := pDisp as IWebBrowser;
(CurrentWB.Document as IHTMLDocument2).DesignMode := 'On';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('http://wp.netscape.com/assist/net_sites/example1-F.html')
end;

Check if a user has administrator rights in NT

Problem/Question/Abstract:

How to check if a user has administrator rights in NT

Answer:

Solve 1:

{ ... }
const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));

const
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;

function IsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
x: Integer;
bSuccess: BOOL;
begin
Result := False;
bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken);
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken);
end;
if bSuccess then
begin
GetMem(ptgGroups, 1024);
bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups,
1024, dwInfoBufferSize);
CloseHandle(hAccessToken);
if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators);
for x := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
begin
Result := True;
Break;
end;
FreeSid(psidAdministrators);
end;
FreeMem(ptgGroups);
end;
end;


Solve 2:

function IsAdmin: boolean;
{Returns a boolean indicating whether or not user has admin privileges.
Call only when running under NT.}
var
hAccessToken: THandle;
ptgGroups: pTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
i: integer; {counter}
blnResult: boolean; {return flag}
const
SECURITY_NT_AUTHORITY: SID_IDENTIFIER_AUTHORITY = (Value: (0, 0, 0, 0, 0, 5));
{ntifs}
SECURITY_BUILTIN_DOMAIN_RID: DWORD = $00000020;
DOMAIN_ALIAS_RID_ADMINS: DWORD = $00000220;
DOMAIN_ALIAS_RID_USERS: DWORD = $00000221;
DOMAIN_ALIAS_RID_GUESTS: DWORD = $00000222;
DOMAIN_ALIAS_RID_POWER: DWORD = $000002203;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
begin
Result := True;
Exit;
end;
Result := False;
ptgGroups := nil;
blnResult := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken);
if not blnResult then
begin
if GetLastError = ERROR_NO_TOKEN then
blnResult := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken);
end;
if blnResult then
try
GetMem(ptgGroups, 1024);
blnResult := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups,
1024, dwInfoBufferSize);
CloseHandle(hAccessToken);
if blnResult then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
for i := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[i].Sid) then
begin
Result := True;
Break;
end;
{$IFDEF RPLUS}{$R+}{$ENDIF}
FreeSid(psidAdministrators);
end;
finally;
if ptgGroups <> nil then
FreeMem(ptgGroups);
end;
end;

Determine ADO and DAO Versions installed

Problem/Question/Abstract:

Function to determine the highest version of DAO installed on the machine. If no DAO is installed then 0.0 is returned. Typical return values are 3.5 or 3.6 for DAO v3.5 and v3.6.

Function to return the current version of ADO installed. A typical return value is 2.7. If ADO is not available then 0.0 is retuened.

Both functions also support a String result function as well.

function GetDaoVersion: double;
function GetDaoVersionStr: string;

function GetAdoVersion: double;
function GetAdoVersionStr: string;

Answer:

// Add to uses clause
uses Math, ComObj;

// ======================================
// Get Highest DAO ver installed
// ======================================

function GetDaoVersion: double;
var
sPath: string;
iError, iResult: integer;
rDirInfo: TSearchRec;
begin
iResult := 0;
sPath := ExtractFileDrive(WindowsDir) +
'\Program Files\Common Files\' +
'Microsoft Shared\DAO\dao*.dll';

// Loop thru to find the MAX DLL version on disk
iError := FindFirst(sPath, faAnyFile, rDirInfo);

while iError = 0 do
begin
iResult := Max(iResult, StrToIntDef(copy(rDirInfo.Name, 4, 3), 0));
iError := FindNext(rDirInfo);
if iError <> 0 then
FindClose(rDirInfo);
end;

Result := (iResult / 100.0);
end;

function GetDaoVersionStr: string;
begin
Result := FormatFloat('##0.00', GetDaoVersion);
end;

// =====================
// Get ADO Version
// =====================

function GetAdoVersion: double;
var
oADO: OLEVariant;
begin
try
oADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(oADO.Version);
oADO := Unassigned;
except
Result := 0.0;
end;
end;

function GetAdoVersionStr: string;
begin
Result := FormatFloat('##0.00', GetAdoVersion);
end;

Change the color of a TOleContainer

Problem/Question/Abstract:

How to change the color of a TOleContainer

Answer:

Basically you have to make a descendent class and reimplement the Paint method. This has some snags to deal with, like references to private fields of the TOleContainer class. Here is an example from a custom TOleContainer descendent.

The Paint method is basically copied from TOlecontainer.Paint and modified to fix a bug in painting the controls background. TOlecontainer uses DrawEdge with BF_MIDDLE as flag and that fills the background gray, ignoring the color set for the control. Since TOLecontainer.Paint makes reference to a number of private fields of the controls some nested functions are introduced to get access to these fields values.

procedure TStructureBox.Paint;

function DrawAspect: Longint;
begin
if Iconic then
result := DVASPECT_ICON
else
result := DVASPECT_CONTENT
end;

function DocObj: boolean;
var
wnd: HWND;
begin
(Self as IOleInPlaceSite).GetWindow(wnd);
result := wnd = Handle;
end;

function UIActive: Boolean;
begin
result := state = osUIActive;
end;

function ObjectOpen: Boolean;
begin
result := state = osOpen;
end;

function Viewsize: TPoint;
var
ViewObject2: IViewObject2;
begin
if Succeeded(OleObjectInterface.QueryInterface(IViewObject2, ViewObject2)) then
ViewObject2.GetExtent(DrawAspect, -1, nil, Result)
else
Result := Point(0, 0);
end;

var
W, H: Integer;
S: TPoint;
R, CR: TRect;
Flags: Integer;
begin
if DocObj and UIActive then
Exit;
CR := Rect(0, 0, Width, Height);
if BorderStyle = bsSingle then
begin
if NewStyleControls and Ctl3D then
Flags := BF_ADJUST or BF_RECT
else
Flags := BF_ADJUST or BF_RECT or BF_MONO;
end
else
Flags := BF_FLAT;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := Color;
{Main modification are the following two lines}
DrawEdge(Canvas.Handle, CR, EDGE_SUNKEN, Flags);
Canvas.FillRect(CR);
if OleObjectInterface <> nil then
begin
W := CR.Right - CR.Left;
H := CR.Bottom - CR.Top;
S := HimetricToPixels(ViewSize);
if (DrawAspect = DVASPECT_CONTENT) and (SizeMode = smScale) then
if W * S.Y > H * S.X then
begin
S.X := S.X * H div S.Y;
S.Y := H;
end
else
begin
S.Y := S.Y * W div S.X;
S.X := W;
end;
if (DrawAspect = DVASPECT_ICON) or (SizeMode = smCenter) or (SizeMode = smScale)
then
begin
R.Left := (W - S.X) div 2;
R.Top := (H - S.Y) div 2;
R.Right := R.Left + S.X;
R.Bottom := R.Top + S.Y;
end
else if SizeMode = smClip then
begin
SetRect(R, CR.Left, CR.Top, S.X, S.Y);
IntersectClipRect(Canvas.Handle, CR.Left, CR.Top, CR.Right, CR.Bottom);
end
else
SetRect(R, CR.Left, CR.Top, W, H);
OleDraw(OleObjectInterface, DrawAspect, Canvas.Handle, R);
if ObjectOpen then
ShadeRect(Canvas.Handle, CR);
end;
if Focused then
Canvas.DrawFocusRect(CR);
end;

Remove the minimize,maximize,restore and system menu buttons from a QuickReport

Problem/Question/Abstract:

How do we remove the minimize,maximize,restore and system menu buttons from a QuickReport?

Answer:

This works only if a TQuickReport object is on a TForm (TMyReport is a TForm in the example bellow).
Just add the following code in the StartPage event of the TQuickReport object:

procedure TMyReport.QuickRep1StartPage(Sender: TCustomQuickRep);
var
i: integer;
begin
for i := Screen.FormCount - 1 downto 0 do
begin
if Screen.Forms[i].ClassName = 'TQRStandardPreview' then
Screen.Forms[i].BorderIcons := Screen.Forms[i].BorderIcons - [biSystemmenu] -
[biMaximize] - [biMinimize];
end;
end;

Where in the project files does Delphi store icons?

Problem/Question/Abstract:

After I add an icon to Project, Options, Application, what file(s) must I back up (or update to my version control system) to be sure the changes are backed up?

Answer:

The .res file contains the icon and version information. The .dof file also contains this, but it can be erased safely as it is refreshed from the .res file whenever you load a project into the IDE.

The command line compiler uses the .res file only. The IDE uses both. I would strongly recommend not saving the .dof file to your version control system since it can also contain things that you don't want stored there, such as a list of components to be loaded when starting the project -- if Joe is developing a component and he saves his .dof file to the vcs, Ralph may end up not being able to start Delphi because Joe's component still needs work or isn't installed on Ralph's machine.

Using CreateProcess to execute programs

Problem/Question/Abstract:

How can I properly use CreateProcess to instantiate a new process?

Answer:

What's a Process

Before I give you the code to execute a program in Windows with CreateProcess, I feel we should delve a bit into the concept of a what a process is. With Win32, Microsoft changed nomenclature to help make the distinction of new concepts more clear for developers. Unfortunately, not everyone understood it - including myself at first. In Win16 a process was the equivalent to an application. That was just fine because Windows 3.1 was (and still is) a non-preemptive multitasking system - there's no such thing as threads.

But with the move to Win32 (Win95 and NT), many people have made the mistake of equating a thread to a process. It's not an unusual thing considering the familiarity with an older concept. However, threads and processes are both distinct concepts and entities. Threads are children of processes; while processes, on the other hand, are inert system entities that essentially do absolutely nothing but define a space in memory for threads to run - threads are the execution portion of a process and a process can have many threads attached to it. That's it. I won't go into the esoteric particulars of memory locations and addressable space and the like. Suffice it to say that processes are merely memory spaces for threads.

That said, executing a program in Win32 really means loading a process and its child thread(s) in memory. And the way you do that in Win32 is with CreateProcess. Mind you, for backward compatibility, the Win16 calls for executing programs, WinExec and ShellExecute are still supported in the Windows API, and still work. But for 32-bit programs, they're considered obsolete. Okay, let's dive into some code.

The following code utilizes the CreateProcess API call, and will execute any program, DOS or Windows.

{Supply a fully qualified path name in ProgramName}

procedure ExecNewProcess(ProgramName: string);
var
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CreateOK: Boolean;
begin

  { fill with known state }
  FillChar(StartInfo, SizeOf(TStartupInfo), #0);
  FillChar(ProcInfo, SizeOf(TProcessInformation), #0);
  StartInfo.cb := SizeOf(TStartupInfo);

  CreateOK := CreateProcess(PChar(ProgramName), nil, nil, nil, False,
    CREATE_NEW_PROCESS_GROUP + NORMAL_PRIORITY_CLASS,
    nil, nil, StartInfo, ProcInfo);

  { check to see if successful }
  if CreateOK then
    //may or may not be needed. Usually wait for child processes
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end;

Okay, while the code above works just fine for executing an application, one my readers pointed out that it doesn't work with programs that include a command line argument. Why? Because CreateProcess' first parameter expects a fully qualified program name (path\executable) and nothing else! In fact, if you include a command line in that parameter, CreateProcess will do nothing. Yikes! In that case, you have to use the second argument. In fact, you can use the second parameter even for just executing a program with no command line. Given that, ExecNewprocess would be changed as follows:

{Supply a fully qualified path name in ProgramName
and any arguments on the command line. As the help file
states: "If lpApplicationName is NULL, the first white space-delimited
token of the command line specifies the module name..." In English,
the characters before the first space encountered (or if no space is
encountered as in a single program call) is interpreted as the
EXE to execute. The rest of the string is the argument line.}

procedure ExecNewProcess(ProgramName: string);
var
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CreateOK: Boolean;
begin

  { fill with known state }
  FillChar(StartInfo, SizeOf(TStartupInfo), #0);
  FillChar(ProcInfo, SizeOf(TProcessInformation), #0);
  StartInfo.cb := SizeOf(TStartupInfo);

  CreateOK := CreateProcess(nil, PChar(ProgramName), nil, nil, False,
    CREATE_NEW_PROCESS_GROUP + NORMAL_PRIORITY_CLASS,
    nil, nil, StartInfo, ProcInfo);

  { check to see if successful }
  if CreateOK then
    //may or may not be needed. Usually wait for child processes
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end;

I know, it's a bit of complex call. And the documentation and online help aren't much help in getting information on it. I think the biggest problem people have working with the WinAPI through Delphi is that the help topics are directed towards C/C++ programmers, not Delphi programmers. So on the fly, Delphi programmers have to translate the C/C++ conventions to Delphi. This has caused a lot of confusion for me and others who have been exploring threads and processes. With luck, we'll see better documentation emerge from either Borland or a third-party source.

Use an image to display an assignment between two lists of strings in a TStringGrid

Problem/Question/Abstract:

I want to show an assignment of two lists of strings in a TStringGrid or something similar. In the first column I write the first list and in the third the other list. In the second column I want to show an icon of an arrow. When the user clicks the arrow it changes the direction of the assignment. Is there a possibility to show icons in a column?

Answer:

You can do that without problems using a TStringGrid. You use the grid's OnDrawCell handler to draw a cells content yourself. What you need, of course, is a way to store the direction of the assignment somewhere, so you know which of the arrows to draw. You could use a special string stored into the cell in column 2 for this, e.g. an empty string to signify -> and a blank character to signify <-. You also need a handler for the grids OnClick event, so you can detect clicks on a cell to invert the assignment.

Lets make an example application. Create a new form, drop a TImageList and a TStringGrid onto it. Set the stringgrid to 3 columns, 0 fixed columns. Load the two arrow bitmaps into the imagelist, the one for left-to-right assignment at index 0, the other at index 1. Name the imagelist "Arrows". Add handlers for the forms OnCreate event and for the stringgrid's OnDrawCell, OnClick, and OnKeyPress events. Modify the unit as below:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, stdctrls, Grids, ImgList;

type
  TAssignment = (aLeftToRight, aRightToLeft);
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    Arrows: TImageList;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1Click(Sender: TObject);
    procedure StringGrid1KeyPress(Sender: TObject; var Key: Char);
  private
    function GetAssignment(index: Integer): TAssignment;
    procedure SetAssignment(index: Integer; const Value: TAssignment);
    procedure ValidateAssignmentIndex(index: INteger);
  public
    procedure ToggleAssignment(index: Integer);
    property Assignment[index: Integer]: TAssignment read GetAssignment write
      SetAssignment;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{Return the top position of an object of height h vertically centered in rectangle rect}

function CenterVertical(const rect: TRect; h: Integer): Integer;
begin
  Result := (rect.bottom + rect.top - h) div 2;
end;

{ Return the left position of an object of width w horizontally centered in rectangle rect}

function CenterHorizontal(const rect: TRect; w: Integer): Integer;
begin
  Result := (rect.right + rect.left - w) div 2;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  grid: TStringgrid;
begin
  if (arow > 0) and (acol = 1) then
  begin
    grid := (Sender as TStringGrid);
    grid.canvas.Brush.color := stringgrid1.color; {disables highlight}
    grid.Canvas.FillRect(rect);
    arrows.Draw(grid.canvas, CenterHorizontal(rect, arrows.Width),
      CenterVertical(rect, arrows.Height), Ord(Assignment[arow] = aRightToLeft));
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  with stringgrid1 do
  begin
    cells[0, 0] := 'Source';
    cells[1, 0] := 'Link';
    cells[2, 0] := 'Dest';
    for i := 1 to rowcount - 1 do
    begin
      cells[0, i] := format('Source %d', [i]);
      Assignment[i] := aLeftToRight;
      cells[2, i] := format('Dest %d', [i]);
    end;
  end;
end;

procedure TForm1.StringGrid1Click(Sender: TObject);
var
  pt: TPoint;
  grid: TStringGrid;
  acol, arow: Integer;
begin
  grid := (Sender as TStringGrid);
  pt := grid.ScreenToClient(mouse.cursorpos);
  grid.MouseToCell(pt.X, pt.y, acol, arow);
  if (aRow > 0) and (aCol = 1) then
    ToggleAssignment(aRow);
end;

const
  AssignmentStrings: array[TAssignment] of string = ('', #32);

function TForm1.GetAssignment(index: Integer): TAssignment;
begin
  ValidateAssignmentIndex(index);
  for Result := Low(Result) to High(Result) do
    if AssignmentStrings[Result] = Stringgrid1.Cells[1, index] then
      Exit;
  raise
    Exception.CreateFmt('The cell value "%s" is not valid as a code
                        for an assignment ' + 'for row %d', [Stringgrid1.Cells[1, index], index]);
end;

procedure TForm1.SetAssignment(index: Integer; const Value: TAssignment);
begin
  ValidateAssignmentIndex(index);
  stringgrid1.Cells[1, index] := AssignmentStrings[value];
end;

procedure TForm1.ToggleAssignment(index: Integer);
const
  toggles: array[TAssignment] of TAssignment = (aRightToLeft, aLeftToRight);
begin
  Assignment[index] := toggles[Assignment[index]];
end;

procedure TForm1.ValidateAssignmentIndex(index: Integer);
begin
  if (index < stringgrid1.FixedCols) or (index >= stringgrid1.RowCount) then
    raise
      Exception.CreateFmt('Assignment index %d is out of bounds, valid indices are ' +
      '%d to %d.', [index, stringgrid1.fixedcols, stringgrid1.rowcount - 1]);
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
var
  grid: TStringgrid;
begin
  grid := (Sender as TStringGrid);
  if grid.Col = 1 then
  begin
    if Key = #32 then {spacebar}
      ToggleAssignment(grid.Row);
    Key := #0;
  end;
end;

end.

How to give a MDI application a 3D frame

Problem/Question/Abstract:

How to give a MDI application a 3D frame

Answer:

You can give an MDI application a 3D frame in Delphi by overriding the main form's CreateWnd method:

procedure TMainForm.CreateWnd;
begin
  inherited CreateWnd;
  SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle, GWL_EXSTYLE)
    or WS_EX_CLIENTEDGE);
end;

In the interface section of your main form's unit you have a type definition for the main form that
looks something like:

type
  TMainForm = class(TForm)
    { maybe some field are defined here }
  private
    { private declarations }
  public
    { public declarations }
  end;

Add the following two lines immediately preceding the end:

protected

procedure CreateWnd; override;

Now add that procedure that I gave you in the implementation section of the unit:

procedure TMainForm.CreateWnd;
begin
  inherited CreateWnd;
  SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle, GWL_EXSTYLE)
    or WS_EX_CLIENTEDGE);
end;

How to make a TMemo have a RoundRect shape

Problem/Question/Abstract:

Is it possible to change the shape of a TMemo to something like stRoundRec in a TShape?

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  rgn: HRGN;
  r: TRect;
begin
  r := memo1.ClientRect;
  rgn := CreateRoundRectRgn(r.Left, r.top, r.right, r.bottom, 20, 20);
  memo1.BorderStyle := bsNone;
  memo1.Perform(EM_GETRECT, 0, lparam(@r));
  InflateRect(r, -5, -5);
  memo1.Perform(EM_SETRECTNP, 0, lparam(@r));
  SetWindowRgn(memo1.Handle, rgn, true);
end;

How to encrypt and decrypt files or strings

Problem/Question/Abstract:

How to encrypt and decrypt files or strings

Answer:

Here's a simple yet effective encryption function:

unit EZCrypt;

{modeled by Ben Hochstrasser(bhoc@surfeu.ch) after some code snippet from Borland}

interface

uses
  Windows, Classes;

type
  TWordTriple = array[0..2] of Word;

function FileEncrypt(InFile, OutFile: string; Key: TWordTriple): boolean;
function FileDecrypt(InFile, OutFile: string; Key: TWordTriple): boolean;
function TextEncrypt(const s: string; Key: TWordTriple): string;
function TextDecrypt(const s: string; Key: TWordTriple): string;
function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer;
  TargetSize: Cardinal; Key: TWordTriple): boolean;
function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer;
  TargetSize: Cardinal; Key: TWordTriple): boolean;

implementation

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer;
  TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i: Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end
  else
    Result := False;
end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer;
  TargetSize: Cardinal; Key: TWordTriple): boolean;
var
  pIn, pOut: ^byte;
  i: Cardinal;
begin
  if SrcSize = TargetSize then
  begin
    pIn := Src;
    pOut := Target;
    for i := 1 to SrcSize do
    begin
      pOut^ := pIn^ xor (Key[2] shr 8);
      Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];
      inc(pIn);
      inc(pOut);
    end;
    Result := True;
  end
  else
    Result := False;
end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;
var
  bOK: Boolean;
begin
  SetLength(Result, Length(s));
  if Encrypt then
    bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)
  else
    bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);
  if not bOK then
    Result := '';
end;

function FileCrypt(InFile, OutFile: string; Key: TWordTriple; Encrypt: Boolean):
  boolean;
var
  MIn, MOut: TMemoryStream;
begin
  MIn := TMemoryStream.Create;
  MOut := TMemoryStream.Create;
  try
    MIn.LoadFromFile(InFile);
    MOut.SetSize(MIn.Size);
    if Encrypt then
      Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)
    else
      Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);
    MOut.SaveToFile(OutFile);
  finally
    MOut.Free;
    MIn.Free;
  end;
end;

function TextEncrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, True);
end;

function TextDecrypt(const s: string; Key: TWordTriple): string;
begin
  Result := TextCrypt(s, Key, False);
end;

function FileEncrypt(InFile, OutFile: string; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, True);
end;

function FileDecrypt(InFile, OutFile: string; Key: TWordTriple): boolean;
begin
  Result := FileCrypt(InFile, OutFile, Key, False);
end;

end.

Fast italian-code-for-companies check function

Problem/Question/Abstract:

In my old article "How to check italian code for companies" there was a explanation how to get information from italian code for companies, but someone recently mailed me that a simply checker version of that function is needed instead. There's the solution.

Answer:

function PartitaIVA(code: string): boolean;
  function ReduceSum(n: Integer): Integer;
  var
    i: Integer;
    s: string;
  begin
    s := inttostr(n);
    if (length(s) = 1) then
    begin
      result := n;
      exit;
    end;
    result := 0;
    for i := 1 to length(s) do
    begin
      result := result + strtointdef(s[i], 0);
    end;
  end;
  function ReduceNum(n: Integer): Integer;
  var
    s: string;
  begin
    result := n;
    s := inttostr(n);
    if (length(s) > 1) then
    begin
      result := strtointdef(s[length(s)], 0)
    end;
  end;
var
  i: Integer;
  c: Integer;
begin
  result := false;
  if (length(code) <> 11) then
    exit;
  for i := 1 to 11 do
    if (not (code[i] in ['0'..'9'])) then
      exit;
  i := strtointdef(copy(code, 8, 3), 0) - 1;
  if ((i < 0) or (i > 102)) then
    exit;
  c := 0;
  for i := 1 to 10 do
  begin
    if ((i mod 2) = 0) then
      inc(c, reducesum(strtointdef(code[i], 0) * 2))
    else
      inc(c, strtointdef(code[i], 0));
  end;
  result := ((10 - ReduceNum(c)) = strtointdef(code[11], -1));
end;

That's all, removed all output parameter variables for a quickly validity check.

Christian Cristofori

How to change brightness and contrast in large bitmaps

Problem/Question/Abstract:

How to change brightness and contrast in large bitmaps

Answer:

You must change the RBG values of the pixels. For 1, 4 and 8 bit bitmaps, you must edit the palette. For 15 - 32 bit bitmaps, you must edit the pixel direct. For larger bitmaps you should precalulate a table and set the RGB values from this table.

Red := BCTable[Red];
Green := BCTable[Green];
Blue := BCTable[Blue];

You can find the calculation of the table below. The rest is standard source code, look at EFG's Computer Lab for any solution.

I define the brightness and contrast value between 0..255. Other definitions are possible, change BMax, CMax, BNorm and CNorm.


type
  TBCTable = array[Byte] of Byte;

const
  RGBCount = 256;
  RGBMax = 255;
  RGBHalf = 128;
  RGBMin = 0;
  BMax = 128; { Maximal value brightness 100% - 0% = 0% - - 100% }
  CMax = 128; { Maximal value contrast 100% - 0% = 0% - - 100% }
  BNorm = 128; { Normal value brightness 0% }
  CNorm = 128; { Normal value contrast 0% }

procedure CalcBCTable(var ABCTable: TBCTable; ABrightness, AContrast: Integer);
var
  i, v: Integer;
  BOffset: Integer;
  M, D: Integer;
begin
  Dec(ABrightness, BNorm);
  Dec(AContrast, CNorm);
  { precalculation brightness assistance values }
  BOffset := ((ABrightness) * RGBMax div BMax);
  { precalculation contrast assistance values }
  if AContrast < CMax then
  begin { because Division by 0 on 100% }
    if AContrast <= 0 then
    begin { decrement contrast }
      M := CMax + AContrast;
      D := CMax;
    end
    else
    begin { increment contrast }
      M := CMax;
      D := CMax - AContrast;
    end;
  end
  else
  begin
    M := 0;
    D := 1;
  end;
  for i := RGBMin to RGBMax do
  begin
    { calculate contrast }
    if AContrast < CMax then
    begin
      v := ((i - RGBHalf) * M) div D + RGBHalf;
      { restrict to byte range }
      if v < RGBMin then
        v := RGBMin
      else if v > RGBMax then
        v := RGBMax;
    end
    else
    begin { contrast = 100% }
      if i < RGBHalf then
        v := RGBMin
      else
        v := RGBMax;
    end;
    { calculate brightness }
    Inc(v, BOffset);
    { restrict to byte range }
    if v < RGBMin then
      v := RGBMin
    else if v > RGBMax then
      v := RGBMax;
    ABCTable[i] := v;
  end;
end;

How to exchange rows in a matrix

Problem/Question/Abstract:

I'm working with a matrix and I've chosen to use an Array of Array of real to do it (Is it the best way? I need the elements to be of real type). The problem is that I must change a certain line with another. For example, change the first line of the matrix with the second one. How do I do it quickly? I don't want to move element by element.

Answer:

program Matrices;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TMatrixRow = array of Double; {preferrable to Real}
  TMatrix = array of TMatrixRow;

procedure MatrixExchangeRows(M: TMatrix; First, Second: Integer);
var
  Help: TMatrixRow;
begin
  if (First < 0) or (First > High(M)) or (Second < 0) or (Second > High(M)) then
    Exit; {or whatever you like.}
  {Only pointers are exchanged!}
  Help := M[First];
  M[First] := M[Second];
  M[Second] := Help;
end;

procedure MatrixWrite(M: TMatrix);
var
  Row, Col: Integer;
begin
  for Row := 0 to High(M) do
  begin
    for Col := 0 to High(M[Row]) do
      Write(M[Row, Col]: 10: 2);
    Writeln;
  end;
  Writeln;
end;

var
  Matrix: TMatrix;
  Row, Column: Integer;

begin
  Randomize;
  SetLength(Matrix, 4, 4);
  for Row := 0 to High(Matrix) do
    for Column := 0 to High(Matrix[Row]) do
      Matrix[Row, Column] := Random * 1000.0;
  MatrixWrite(Matrix);
  MatrixExchangeRows(Matrix, 1, 2);
  MatrixWrite(Matrix);
  Readln;
end.

How to split up a formatted source string into substrings and integers

Problem/Question/Abstract:

How to split up a formatted source string into substrings and integers

Answer:

function Unformat(const source, pattern: string; const args: array of const): Integer;

{The opposite of Format, Unformat splits up a formatted source string into substrings and Integers.
It is an alternative to parsing when the format is known to be fixed.  The pattern parameter contains the format string, which is a combination of plain characters and format specifiers.

The following specifiers are supported:

%s   indicates that a string value is required
%d   indicates that an integer value is required
%S   indicates that a string value should be ignored
%D   indicates that an integer value should be ignored

Unformat compares the source with the pattern, and plain characters  that do not match will raise an EConvertError. When a format specifier is encountered in the pattern, an argument is fetched and used to store the result that is obtained from the source. Then the comparison continues.

For each %s, the args list must contain a pointer to a string variable, followed by an integer specifying the maximum length of the string. For each %d, the args list must contain a pointer to an integer variable.

When the end of the source string is reached, the function returns without modifying the remaining arguments, so you might wish to initialize your variables to "default" values before the function call.

Unformat returns the number of values it has extracted.

Examples:

  var
    s1, s2: string[31];
    i: Integer;

  Unformat('[abc]123(def)', '[%s]%d(%s)', [@s1, 31, @i, @s2, 31]);
    (* s1 = 'abc', i = 123, s2 = 'def' *)

  Unformat('Hello, Universe!!!', '%s, %s%d', [@s1, 31, @s2, 31, @i]);
    (* s1 = 'Hello', s2 = 'Universe!!!', i is untouched *)

  Unformat('How much wood could a woodchuck chuck...',
           '%S %S %s could a %S %s...', [@s1, 31, @s2, 31]);
    (* s1 = 'wood', s2 = 'chuck' *)
}

  function Min(a, b: Integer): Integer; assembler;

    { use AX for 16-bit, EAX for 32-bit }
  asm
      MOV     EAX,a
      CMP     EAX,b
      JLE       @@1
      MOV     EAX,b
      @@1:
  end;

var
  i, j, argindex, start, finish, maxlen: Integer;
  c: Char;
begin
  Result := 0;
  argindex := 0;
  i := 1;
  j := 1;
  while (i < Length(pattern)) and (j <= Length(source)) do
  begin
    if pattern[i] = '%' then
      case pattern[i + 1] of
        'D':
          begin
            Inc(i, 2);
            while (j <= Length(source)) and ((source[j] in Digits) or (source[j] =
              '-')) do
              Inc(j);
            Inc(Result);
          end;
        'S':
          begin
            Inc(i, 2);
            if i > Length(pattern) then
              break
            else
            begin
              c := pattern[i];
              while (j <= Length(source)) and (source[j] <> c) do
                Inc(j);
            end;
            Inc(Result);
          end;
        'd':
          begin
            if argindex > High(args) then
              raise EConvertError.Create('Not enough arguments');
            Inc(i, 2);
            start := j;
            while (j <= Length(source)) and ((source[j] in Digits) or (source[j] =
              '-')) do
              Inc(j);
            finish := j;
            if finish > start then
              PInteger(args[argindex].VPointer)^ := StrToInt(Copy(source, start,
                                                         finish - start));
            Inc(argindex);
            Inc(Result);
          end;
        's':
          begin
            if argindex > High(args) - 1 then
              raise EConvertError.Create('Not enough arguments');
            if args[argindex + 1].VType <> vtInteger then
              raise EConvertError.Create('No string size specified');
            maxlen := args[argindex + 1].VInteger;
            Inc(i, 2);
            if i > Length(pattern) then
            begin
              args[argindex].VString^ := Copy(source, j, Min(Length(source) + 1 - j,
                maxlen));
              Inc(argindex);
              break;
            end
            else
            begin
              c := pattern[i];
              start := j;
              while (j <= Length(source)) and (source[j] <> c) do
                Inc(j);
              finish := j;
              args[argindex].VString^ := Copy(source, start, Min(finish - start,
                maxlen));
              Inc(argindex, 2);
            end;
            Inc(Result);
          end;
      else
        Inc(i);
      end
    else
      {if pattern[i] <> source[j] then
        raise EConvertError.Create('Pattern mismatch')
      else}
    begin
      Inc(i);
      Inc(j);
    end;
  end;
end;

Determine if a polygon is concave or not

Problem/Question/Abstract:

How to determine if a polygon is concave or not

Answer:

I would check the area of 3 triangle points of the polygon. It should always be positive. Here is the code:

function TriXYArea(PBegin, PMiddle, PEnd: TXYPoint): TDouble;
begin
  TriXYArea := (PBegin.y + PMiddle.y) / 2 * (PMiddle.x - PBegin.X) + (PMiddle.y +
    PEnd.y) / 2 * (PEnd.x - PMiddle.X) + (PBegin.y + PEnd.y) / 2 * (PBegin.x -
      PEnd.X);
end;

If the polygon is clockwise oriented (the Gauss integral is positive), it should work like this:

function IsConvex(Poly: array of TXYPoint);
var
  i: Integer;
  First, Mid, Last: TXYPoint;
begin
  Result := False;
  for i := 1 to High(Poly) do
  begin
    if i < High(Poly) then
    begin
      First := Poly[i - 1];
      Mid := Poly[i];
      Last := Poly[i + 1];
    end
    else
    begin
      First := Poly[i - 1];
      Mid := Poly[i];
      Last := Poly[0];
    end;
    if TriXYArea(First, Mid, Last) < 0 then
      exit;
  end;
  Result := True;
end;

If you only want to use the angle, here is the function:

function TriXYAngle(PBegin, PMiddle, PEnd: TXYPoint): TDouble;
var
  AC, ACX, ACG, TR: TDouble;
begin
  TriXYAngle := 1E38;
  TR := TriXYArea(PBegin, PMiddle, PEnd);
  AC := TriXYCos(PBegin, PMiddle, PEnd);
  ACX := ArcCos(AC);
  ACG := ACX / Pi * 180;
  if Tr >= 0 then
    TriXYAngle := +ACG;
  if Tr < 0 then
    TriXYAngle := 360 - ACG;
  if AC = 1E38 then
    TriXYAngle := 1E38;
end;

Detect If an Application Has Stopped Responding

Problem/Question/Abstract:

In many situations you might like to detect if an application is blocked. For example while automating Word, you'd like to know if Word has stopped responding.
This article describes how to detect if an application has stopped responding using some undocumented functions.

Answer:

{
  // (c)1999 Ashot Oganesyan K, SmartLine, Inc
  // mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

The code doesn't use the Win32 API SendMessageTimout function to
determine if the target application is responding but calls
undocumented functions from the User32.dll.

--> For Windows 95/98/ME we call the IsHungThread() API

The function IsHungAppWindow retrieves the status (running or not responding)
of the specified application

IsHungAppWindow(Wnd: HWND): // handle to main app's window
BOOL;

--> For NT/2000/XP the IsHungAppWindow() API:

The function IsHungThread retrieves the status (running or not responding) of
the specified thread

IsHungThread(DWORD dwThreadId): // The thread's identifier of the main app's window
BOOL;

  Unfortunately, Microsoft doesn't provide us with the exports symbols in the
  User32.lib for these functions, so we should load them dynamically using the GetModuleHandle and
  GetProcAddress functions:
}

// For Win9x/ME

function IsAppRespondig9x(dwThreadId: DWORD): Boolean;
type
  TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungThread: TIsHungThread;
begin
  Result := True;
  hUser32 := GetModuleHandle('user32.dll');
  if (hUser32 > 0) then
  begin
    @IsHungThread := GetProcAddress(hUser32, 'IsHungThread');
    if Assigned(IsHungThread) then
    begin
      Result := not IsHungThread(dwThreadId);
    end;
  end;
end;

// For Win NT/2000/XP

function IsAppRespondigNT(wnd: HWND): Boolean;
type
  TIsHungAppWindow = function(wnd: hWnd): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungAppWindow: TIsHungAppWindow;
begin
  Result := True;
  hUser32 := GetModuleHandle('user32.dll');
  if (hKernel > 0) then
  begin
    @IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');
    if Assigned(IsHungAppWindow) then
    begin
      Result := not IsHungAppWindow(wnd);
    end;
  end;
end;

function IsAppRespondig(Wnd: HWND): Boolean;
begin
  if not IsWindow(Wnd) then
  begin
    ShowMessage('Incorrect window handle');
    Exit;
  end;
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    Result := IsAppRespondigNT(wnd)
  else
    Result := IsAppRespondig9X(GetWindowThreadProcessId(wnd, nil));
end;

// Example: Check if Word is hung/responing

procedure TForm1.Button3Click(Sender: TObject);
var
  Res: DWORD;
  h: HWND;
begin
  // Find Word by classname
  h := FindWindow(PChar('OpusApp'), nil);
  if h <> 0 then
  begin
    if IsAppRespondig(h) then
      ShowMessage('Word is responding')
    else
      ShowMessage('Word is not responding');
  end
  else
    ShowMessage('Word is not open');
end;

Close all MDI child forms at once

Problem/Question/Abstract:

How to close all MDI child forms at once

Answer:

var
  cik: integer;

for cik := MDIChildCount - 1 downto 0 do
begin
  MDIChildren[cik].Close;
end;

How to force IExplorer to re-read registry settings

Problem/Question/Abstract:

I've written a small app that modifies a setting for IE and need to somehow tell IE to re-read the registry settings. Does anyone know of an API call or message that will do this?

Answer:

This will do the trick:

{ ... }
var
  HInet: HINTERNET;
  { ... }
  HInet := InternetOpen(PChar('SomeAppName'), INTERNET_OPEN_TYPE_DIRECT,
    nil, nil, INTERNET_FLAG_OFFLINE);
try
  if HInet <> nil then
    InternetSetOption(HInet, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);
finally
  InternetCloseHandle(HInet);
end;

Count the lines of text contained in a text file

Problem/Question/Abstract:

How to count the lines of text contained in a text file

Answer:

Solve 1:

The fastest way would be to count the instances of #13#10 yourself. However you need to be careful because #13 and #10 could easily be swapped to give #10#13 instead which makes this kind of counting more difficult. In this case it's far easier just to count the instances of one of them and this has the bonus of being more compatible with non-Windows (ie. non CR/LF'd) files - not all operating systems bother with both #13 and #10. The following is a basic implementation of the code:

function CountLines(const FileName: string): integer;
const
  BufferSize = 1024;
  SearchByte = 10;
var
  FileHandle, BytesRead, Index: integer;
  Buffer: array[1..BufferSize] of byte;
begin
  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);
  BytesRead := FileRead(FileHandle, Buffer[1], BufferSize);
  if (BytesRead > 0) then
    Result := 1
  else
    Result := 0;
  repeat
    for Index := 1 to Min(BufferSize, BytesRead) do
    begin
      if (Buffer[Index] = SearchByte) then
        Inc(Result);
    end;
    BytesRead := FileRead(FileHandle, Buffer[1], BufferSize);
  until
    BytesRead <= 0;
  FileClose(FileHandle);
end;

This code is searching for #10's in the file, and treating this as a line delimeter. It takes care of the case where an empty file has 0 lines but a file with no #10s has one line in the initialisation of the Result return value. You can easily modify the seach byte and/or the buffer size.


Solve 2:

If it is a smaller file (< 1 MB) load it into a TStringlist and look at the stringlists Count property. If it is larger you need to read it completely and count lines. A simple loop would be this:

function CountLines(const filename: string): Integer;
var
  buffer: array[0..4095] of Char;
  f: Textfile;
begin
  Result := 0;
  Assignfile(f, filename);
  Reset(f);
  try
    SetTextBuffer(f, buffer, sizeof(buffer));
    while not Eof(f) do
    begin
      readLn(f);
      Inc(result);
    end;
  finally
    Closefile(f);
  end;
end;

Using a larger than the default buffer of 128 bytes speeds the reading somewhat.


Solve 3:

Buffering can help quit a bit:

function TextLineCount_BufferedStream(const Filename: TFileName): Integer;
const
  MAX_BUFFER = 1024 * 1024;
var
  oStream: TFileStream;
  sBuffer: string;
  iBufferSize: Integer;
  iSeek: Integer;
  bCarry: Boolean;
begin
  Result := 0;
  bCarry := False;
  oStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    SetLength(sBuffer, MAX_BUFFER);
    repeat
      iBufferSize := oStream.Read(sBuffer[1], MAX_BUFFER);
      if iBufferSize <= 0 then
        break;
      {Skip LFs that follow a CR - even if it falls in seperate buffers}
      iSeek := 1;
      if bCarry and (sBuffer[1] = #10) then
        Inc(iSeek);
      while iSeek <= iBufferSize do
      begin
        case sBuffer[iSeek] of
          #10:
            Inc(Result);
          #13:
            if iSeek = iBufferSize then
              Inc(Result)
            else if sBuffer[iSeek + 1] <> #10 then
              Inc(Result)
            else
            begin
              Inc(Result);
              Inc(iSeek);
            end;
        end;
        Inc(iSeek);
      end;
      {Set carry flag for next pass}
      bCarry := (sBuffer[iBufferSize] = #13);
    until
      iBufferSize < MAX_BUFFER;
  finally
    FreeAndNil(oStream);
  end;
end;

Dragging controls and forms the easy way

Problem/Question/Abstract:

This article shows a technique to drag a form without caption other than responding to NC_HITTEST messages. This technique can also be used to accomplish the dragging of Windowed controls inside the form.

Answer:

The code bellow was created when I was writting a component to allow the dragging of forms without captions. First I found code using the NC_HITTEST message, but the technique presented here offers a lot of other possibilities since it can be applied to any windowed control (not only forms), and will allow you to move them on the form with only 2 or 3 lines of code.

It consists of sendind a WM_SYSCOMMAND message to the desired window (remember that all windowed controls are considered windows on the Windows OS :-) with the correct parameters set, and the window will behave as if the user had started dragging the window by clicking on its caption (this works even with windows without captions, like text boxes.)

The funny part was that this parameter for the WM_SYSCOMMAND message isn't documented (it isn't on my Windows SDK help). I've discovered it while debugging an application. I've put a handler for the WM_SYSCOMMAND message and was showing on the screen all the values for its parameters and to my surprise, when I started to drag the form the value $F012 poped-up. Then I tried to send it to the form and it didn't worked. After a while I figure out how to do it correctly and the code for this follows:

Put the code bellow on the OnMouseDown handler for any form:

procedure TForm1.FormMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    Perform(WM_SYSCOMMAND, $F012, 0);
  end;
end;

You can also put this code on the OnMouseDown of a single panel or a group of panels, effectively creating a new drag point for the form. When the user tries to drag the panel you send the message above to the form and a dragging operation will start. It is easier to accomplish this with this method than using the NC_HITTEST message:

procedure TForm1.Panel1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    Perform(WM_SYSCOMMAND, $F012, 0);
  end;
end;

If you write

Panel1.Perform(WM_SYSCOMMAND, $F012, 0)

the panel will start moving inside the form as if it was itself a form. When you release the mouse it will stay were you left it (no additional code required).

This code can be much useful sometimes, but it is very very simple. Hope you liked it.

I played a bit with the code modifying the $F000 Part.

$F000 (Center cursor on the form)
$F001 (Resize from left)
$F002 (Resize from right)
$F003 (Resize from up)
$F004 (Lock the bottom right corner of the form, the up left corner move for resize)
$F005 (Same from bottom left corner)
$F006 (Lock up right and left border, resize other)
$F007 (Lock up and right border, resize other border)
$F008 (Lock left and up border and resize other)
$F009 (Drag from anywhere)
$F010 (Put cursor centered at the upper order)
$F020 (Auto-Minimize Form)
$F030 (Auto-Maximize Form)
$F040 (Stop! You don't want that, it will lock all mouse click and make
you reboot)
$F148 (Activate ScreenSaver)
$F13E (Activate StartButton)

How to turn off Windows' font anti-aliasing

Problem/Question/Abstract:

How can I temporally turn off the Windows font anti-aliasing and turn it on after drawing?

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    SmoothFonts: Boolean;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  SystemParametersInfo(SPI_GETFONTSMOOTHING, 1, @SmoothFonts, 0);
  if SmoothFonts then
    SystemParametersInfo(SPI_SETFONTSMOOTHING, 0, nil, SPIF_UPDATEINIFILE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if SmoothFonts then
    SystemParametersInfo(SPI_SETFONTSMOOTHING, 1, nil, SPIF_UPDATEINIFILE);
end;

end.

Under Win95 it has only an effect if the Plus! Pack is installed (NT4 by default).

How to calculate the age based on the date of birth

Problem/Question/Abstract:

How to calculate the age based on the date of birth.

Answer:

Solve 1:

{ BrthDate:  Date of birth }

function TFFuncs.CalcAge(brthdate: TDateTime): Integer;
var
  month, day, year, bmonth, bday, byear: word;
begin
  DecodeDate(BrthDate, byear, bmonth, bday);
  if bmonth = 0 then
    result := 0
  else
  begin
    DecodeDate(Date, year, month, day);
    result := year - byear;
    if (100 * month + day) < (100 * bmonth + bday) then
      result := result - 1;
  end;
end;


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  Month, Day, Year, CurrentMonth, CurrentDay, CurrentYear: word;
  Age: integer;
begin
  DecodeDate(DateTimePicker1.Date, Year, Month, Day);
  DecodeDate(Date, CurrentYear, CurrentMonth, CurrentDay);
  if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
    Age := 0
  else
  begin
    Age := CurrentYear - Year;
    if (Month > CurrentMonth) then
      dec(Age)
    else if Month = CurrentMonth then
      if (Day > CurrentDay) then
        dec(Age);
  end;
  Label1.Caption := IntToStr(Age);
end;

How to send a raw string to the printer

Problem/Question/Abstract:

How to send a raw string to the printer

Answer:

procedure PrintRawStr(const S: ANSIString);

Uses WinSpool, Printers;

var
  sDefaultPrinter: string;
  Handle: THandle;
  dwN: DWORD;
  diDocInfo1: TDocInfo1; // Uses WinSpool
  bP: BYTE;

begin
  // Get the default printer or the printer choosen in the Printer Setup Dialog
  // if you have one in the application
  if Printer.Printers.Count > 0 then
  begin
    sDefaultPrinter := Printer.Printers[Printer.PrinterIndex]; // Uses Printers
    //uses Printers, get default printer
    bP := Pos(' on ', sDefaultPrinter);
    if bP > 0 then
      sDefaultPrinter := Copy(sDefaultPrinter, 1, bP - 1);
  end
  else
    Exit; // No printers installed on this system...

  if not OpenPrinter(PChar(sDefaultPrinter), Handle, nil) then
  begin
    case GetLastError of
      87: ShowMessage('Printer name does not exists.');
    else
      ShowMessage('Error ' + IntToStr(GetLastError)); // Uses Dialogs
    end;
    Exit; // Cannot find the printer
  end;

  with diDocInfo1 do
  begin
    pDocName := PChar('Print job raw'); // Will be seen in printer spooler
    pOutputFile := nil;
    pDataType := 'RAW';
  end;

  StartDocPrinter(Handle, 1, @diDocInfo1);
  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), dwN);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

Change the file name in a TSaveDialog when the user selects a different file type

Problem/Question/Abstract:

How to change the file name in a TSaveDialog when the user selects a different file type

Answer:

You could try this. I'm not sure if the line S := (Sender as TSaveDialog).Filename; works in Delphi 5 or earlier but otherwise it should be okay.

uses
  CommDlg;

procedure TForm1.SaveDialog1TypeChange(Sender: TObject);
var
  S: string;
  H: THandle;
begin
  H := GetParent((Sender as TSaveDialog).Handle);
  S := (Sender as TSaveDialog).Filename;
  if DirectoryExists(S) then
    S := '';
  if S <> '' then
    with TSaveDialog(Sender) do
      case FilterIndex of
        1: S := ChangeFileExt(S, '.rtf');
        2: S := ChangeFileExt(S, '.txt');
      else
        S := '';
      end;
  if S <> '' then
    SendMessage(H, CDM_SETCONTROLTEXT, edt1, longint(PChar(ExtractFileName(S))));
end;

Does a string looks like an integer?

Problem/Question/Abstract:

Does a string looks like an integer?

Answer:

Use this function to determine, whether a given string represents an integer.


function IsInteger(TestThis: string): Boolean;
begin
  try
    StrToInt(TestThis);
  except
    on EConvertError do
      result := False;
  else
    result := True;
  end;
end;


Note: Due to the exception, the program is slow for non-numerical strings. If you expect non-numerical strings very often, you may use a construct basing on the Val() function and evaluate the error code.

Moving multiple components

Problem/Question/Abstract:

Moving multiple components

Answer:

If you want to move multiple components of a given type, say four Buttons, press [Shift] and then click on the component you want to move. You'll be able to move as many instances of that component as you like until you select a different component from the palette, or until you select the Arrow tool.

Converting Text for different Code Pages

Problem/Question/Abstract:

Recently I ran into the problem of converting text for the Shift-JIS (Japanese Idioms) code pages when creating an i-mode interface for my companies Content Management System. But before I was about to start writing all by myself I checked into the tool Microsoft gave us.

Answer:

All Systems (Win 95+ and WinNT4+) with MS Internet Explorer 4 and newer have a library named mlang.dll in the Winnt\System32 directory. Usually you can tell Delphi to simply import these COM Libraries. This one however, Delphi did not. I started to convert the "most wanted" interface for myself. The results I present you here.

First I give you the code for the conversion unit, that allows you simply convert any text from code page interpretation into another one. Following I will shortly discuss the code and give you a sample of how to use it.

uCodePageConverter

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uCodePageConverter
* Autor     : Daniel Wischnewski
* Copyright : Copyright &copy; 2002 by gate(n)etwork. All Right Reserved.
* Urheber   : Daniel Wischnewski
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uCodePageConverter;

interface

uses
  Windows;

const
  IID_MLangConvertCharset: TGUID = '{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}';
  CLASS_MLangConvertCharset: TGUID = '{D66D6F99-CDAA-11D0-B822-00C04FC9B31F}';

type
  tagMLCONVCHARF = DWORD;

const
  MLCONVCHARF_AUTODETECT: tagMLCONVCHARF = 1;
  MLCONVCHARF_ENTITIZE: tagMLCONVCHARF = 2;

type
  tagCODEPAGE = UINT;

const
  CODEPAGE_Thai: tagCODEPAGE = 0874;
  CODEPAGE_Japanese: tagCODEPAGE = 0932;
  CODEPAGE_Chinese_PRC: tagCODEPAGE = 0936;
  CODEPAGE_Korean: tagCODEPAGE = 0949;
  CODEPAGE_Chinese_Taiwan: tagCODEPAGE = 0950;
  CODEPAGE_UniCode: tagCODEPAGE = 1200;
  CODEPAGE_Windows_31_EastEurope: tagCODEPAGE = 1250;
  CODEPAGE_Windows_31_Cyrillic: tagCODEPAGE = 1251;
  CODEPAGE_Windows_31_Latin1: tagCODEPAGE = 1252;
  CODEPAGE_Windows_31_Greek: tagCODEPAGE = 1253;
  CODEPAGE_Windows_31_Turkish: tagCODEPAGE = 1254;
  CODEPAGE_Hebrew: tagCODEPAGE = 1255;
  CODEPAGE_Arabic: tagCODEPAGE = 1256;
  CODEPAGE_Baltic: tagCODEPAGE = 1257;

type
  IMLangConvertCharset = interface
    ['{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}']
    function Initialize(
      uiSrcCodePage: tagCODEPAGE; uiDstCodePage: tagCODEPAGE;
      dwProperty: tagMLCONVCHARF
      ): HResult; stdcall;
    function GetSourceCodePage(
      out puiSrcCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetDestinationCodePage(
      out puiDstCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetProperty(out pdwProperty: tagMLCONVCHARF): HResult; stdcall;
    function DoConversion(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionToUnicode(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PWChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionFromUnicode(
      pSrcStr: PWChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
  end;

  CoMLangConvertCharset = class
    class function Create: IMLangConvertCharset;
    class function CreateRemote(const MachineName: string): IMLangConvertCharset;
  end;

implementation

uses
  ComObj;

{ CoMLangConvertCharset }

class function CoMLangConvertCharset.Create: IMLangConvertCharset;
begin
  Result := CreateComObject(CLASS_MLangConvertCharset) as IMLangConvertCharset;
end;

class function CoMLangConvertCharset.CreateRemote(
  const MachineName: string
  ): IMLangConvertCharset;
begin
  Result := CreateRemoteComObject(
    MachineName, CLASS_MLangConvertCharset
    ) as IMLangConvertCharset;
end;

end.

As you can see, I did translate only one of the many interfaces, however this one is the most efficient (according to Microsoft) and will do the job. Further I added some constants to simplify the task of finding the most important values.

When using this unit to do any code page conersions you must not forget, that the both code pages (source and destination) must be installed and supported on the computer that does the translation. OIn the computer that is going to show the result only the destination code page must be installed and supported.

To test the unit simple create a form with a memo and a button. Add the following code to the buttons OnClick event. (Do not forget to add the conversion unit to the uses clause!)

SAMPLE

procedure TForm1.Button1Click(Sender: TObject);
var
  Conv: IMLangConvertCharset;
  Source: PWChar;
  Dest: PChar;
  SourceSize, DestSize: UINT;
begin
  // connect to MS multi-language lib
  Conv := CoMLangConvertCharset.Create;
  // initialize UniCode Translation to Japanese
  Conv.Initialize(CODEPAGE_UniCode, CODEPAGE_Japanese, MLCONVCHARF_ENTITIZE);
  // load source (from memo)
  Source := PWChar(WideString(Memo1.Text));
  SourceSize := Succ(Length(Memo1.Text));
  // prepare destination
  DestSize := 0;
  // lets calculate size needed
  Conv.DoConversionFromUnicode(Source, @SourceSize, nil, @DestSize);
  // reserve memory
  GetMem(Dest, DestSize);
  try
    // convert
    Conv.DoConversionFromUnicode(Source, @SourceSize, Dest, @DestSize);
    // show
    Memo1.Text := Dest;
  finally
    // free memory
    FreeMem(Dest);
  end;
end;

Further Information regarding code page translations you will find at MSDN - IMLangConvertCharset

How to get workgroup/domain name under NT4/2k/XP

Problem/Question/Abstract:

How do I get the current workgroup?

Answer:

function GetWorkgroupName: string;
type
  P_WKSTA_INFO_100 = ^T_WKSTA_INFO_100;
  _WKSTA_INFO_100 = record
    wki100_platform_id: LongInt;
    wki100_computername: PWideChar;
    wki100_langroup: PWideChar;
    wki100_ver_major: LongInt;
    wki100_ver_minor: LongInt;
  end;
  T_WKSTA_INFO_100 = _WKSTA_INFO_100;
var
  DLLHandle: THandle;
  Info: P_WKSTA_INFO_100;
  NetWkstaGetInfo: function(servername: PAnsiChar; Level: DWord; var Buf:
    P_WKSTA_INFO_100): DWORD; Stdcall;
begin
  Result := '';
  DLLHandle := LoadLibrary('NETAPI32.DLL');
  if DLLHandle = 0 then //Can't load DLL
    exit;
  @NetWkstaGetInfo := GetProcAddress(DLLHandle, 'NetWkstaGetInfo');
  if @NetWkstaGetInfo = nil then //Exported function not found
  begin
    FreeLibrary(DLLHandle);
    exit;
  end;
  if NetWkstaGetInfo(nil, 100, Info) = 0 then
    Result := Info^.wki100_langroup;
  FreeLibrary(DLLHandle);
end;

Right-align the content of a TEdit

Problem/Question/Abstract:

How to right-align the content of a TEdit

Answer:

Solve 1:

procedure TESBPCSCustomEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  case Alignment of
    taLeftJustify: Params.Style := Params.Style or ES_LEFT;
    taRightJustify: Params.Style := Params.Style or ES_RIGHT or ES_MultiLine;
    taCenter: Params.Style := Params.Style or ES_CENTER or ES_MultiLine;
  end;
  if FReadOnly then
    Params.Style := Params.Style or ES_READONLY;
end;


Solve 2:

unit uEditEx;

interface

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

type
  TEditEx = class(TEdit)
  private
    FAlignment: TAlignment;
    procedure SetAlignment(const Value: TAlignment);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
  published
    constructor Create(AOwner: TComponent); override;
    property Alignment: TAlignment
      read FAlignment
      write SetAlignment
      default taLeftJustify;
  end;

procedure Register;

implementation

{R uEditEx.dcr}

procedure Register;
begin
  RegisterComponents('gate(n)etwork', [TEditEx]);
end;

{ TEditEx }

constructor TEditEx.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAlignment := taLeftJustify;
end;

procedure TEditEx.CreateParams(var Params: TCreateParams);
const
  Alignments: array[TAlignment] of Cardinal =
  (ES_LEFT, ES_RIGHT, ES_CENTER);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or {ES_MULTILINE or}  Alignments[FAlignment];
end;

procedure TEditEx.SetAlignment(const Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    RecreateWnd;
  end;
end;

end.