How to create nodes and subnodes of a TTreeView at runtime to represent a master - detail relationship

Problem/Question/Abstract:

I would like to present a master - detail relationship within a TTreeView upon opening a query at runtime. Getting the correct info is not a problem but I'm totally stumped by the use of a TTreeView. Are there commands usable at runtime to enable me to create and edit the nodes/ sub nodes of the treeview to present the master records as nodes and the detail records as sub nodes within the treeview?

Answer:

Here's an example of creating / maintaining TreeNodes at runtime. Before I take off, I assume that you use database tables like the following:

A MASTERTABLE, with fields M_ID (unique identifier) and M_NAME (a descriptive name);
A DETAILTABLE, with fields D_ID (unique identifier), D_NAME (a descriptive name), and D_M_ID (a foreign key value that links the detail record to a master record.)

This could be quite different from what you have, but I need to make assumptions in order to write this example.

The first step of the process is to add all master records as parent nodes of detail nodes. It goes without saying that I need to add parent nodes first, since detail nodes are 'dependent' of them.

You can add all master records to the TreeView by looping the query at runtime and do something like this:

{Get all master records in query}
{ ... }
while not qryMasterRecords.EOF do
begin
  {some code will follow here, be patient my friend.}
  TreeView1.Items.Add(nil, qryMasterRecords.FieldByName('M_NAME').AsString);
  qryMasterRecords.Next;
end;
{ ... }

The Add method (of a TTreeNodes object) adds the node to the TreeView; the first parameter specifies the parent node. (in this case, nil means that it is added as a root node.) The second parameter is the node name that is represented in the TreeView. (this is the Text property of a TTreeNode.)

However, I am finished yet with the master records. How the heck am I going to identify the master nodes when I want to insert detail nodes later on? When adding a detail node, I need to know what its parent should be. A bad answer (to me) is to say that one can use the node name as an identifier. Since we have a unique identifier for each master record in the database, why don't we use it?

The solution to this lies in the Data property of the TreeNode object: This is a pointer one can assign to an application-designed object. The intention is to use such an object to store the unique identifier of the master record.

Let's use an record-type object like this:

type
  PMaster = ^TMaster
    TMaster = record
    Identifier: integer;
  end;

Assuming these types are used, I modify the master-node-adding code to this:

{ ... }
var
  MasterPtr: PMaster;
  { ... }
  {Get all master records in query}
  { ... }
  while not qryMasterRecords.EOF do
  begin
    New(MasterPtr);
    Master^.Identifier := qryMasterRecords.FieldByname('M_ID').AsInteger);
  TreeView1.Items.AddObject(nil, qryMasterRecords.FieldByName('M_NAME').AsString,
    MasterPtr);
  qryMasterRecords.Next;
end;
{ ... }

At runtime, I create a record type object for each record that is found in the query. I use a slightly extended version of the Add method. AddObject also links MasterPtr with the Data property of the new node.

For now, I have finished with the master nodes: The next step is to add all detail nodes. I need to write a small function that searches for a TreeNode with a specified M_ID value. I need this while adding detail nodes, because I need to identify a node that is the parent node of the detail node that is to be inserted.

function SearchMasterNode(iM_ID: integer): TTreeNode;
{Searches for a node with a specified M_ID value. Returns the TreeNode that has the
specified M_ID value. When it is not found, nil is returned.}
var
  iCount: integer;
begin
  {Default value to return}
  Result := nil;
  {For your info: iterating like this loops through all nodes in a TreeView, including detail nodes}
  for iCount := 0 to TreeView1.Items.Count - 1 do
  begin
    if Assigned(TreeView1.Items.Item[iCount].Data) then
      if PMaster(TreeView1.Items.Item[iCount].Data)^.Identifier = iM_ID then
        Result := TreeView1.Items.Item[iCount];
    {We got a match !}
  end;
end;

From now on, adding detail nodes is much like adding master nodes, with one extra move: a search for a parent node.

{ ... }
{Insert all master nodes to the TreeView}
{ ... }
var
  MasterNode: TTreeNode;

  {Get all detail records in query}
  { ... }
  while not qryDetailRecords.EOF do
  begin
    MasterNode := SearchMasterNode(qryDetailRecords.FieldByName('D_M_ID').AsInteger);
    {For your info: The Data property of this new node is set to nil.}
    TreeView1.Items.AddChild(MasterNode,
                                                                                                        qryDetailRecords.FieldByName('D_NAME').AsString);
    qryDetailRecords.Next;
  end;

The Add method is used here, since I assume that you don't need to identify detail nodes for something else. When you do need this (for example, clicking on a detail node must result in the representation of detail record data in edit boxes, memo-boxes, whatever input control.) use the approach with master nodes.

Finally, to create an application that uses computer memory efficiently, I should free all memory used for the record-type objects. I did this by iterating through all nodes and freeing the data objects:

{ ... }
var
  iCount: integer;
  { ... }
  for iCount := 0 to TreeView1.Items.Count - 1 do
  begin
    if Assigned(TreeView1.Items.Item[iCount].Data) then
      Dispose(TreeView1.Items.Item[iCount].Data);
  end;
  {Finally, free all nodes constructed at runtime}
  TreeView1.Items.Clear;
  { ... }

How to check if a user has administrator rights in NT

Problem/Question/Abstract:

How to check if a user has administrator rights in NT

Answer:

{ ... }
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;

How to send messages to threads

Problem/Question/Abstract:

I'm having a problem sending messages to my threads. I can send back to parent form very easily with PostMessage, but I have tried to communicate to my threads via PostMessage and PostThreadMessage to no avail. I read some cryptic remarks in the PostThreadMessage help that seemed to indicate that I would have to induce the API into creating a message queue for the thread. Can anyone shed some light?

Answer:

type
  TMyThread = class(TThread)
    AHwnd: HWND;
    procedure Execute; override;
    procedure Terminate;
    destructor Destroy; override;
  end;

procedure TMyThread.Execute;
var
  msg: TMsg;
  MyTerminated: Boolean;
begin
  MyTerminated := False;
  while not MyTerminated do
  begin
    WaitMessage;
    if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
    begin
      TranslateMessage(Msg);
      case Msg.Message of
        WM_QUIT: MyTerminated := True;
        WM_USER: PostMessage(AHwnd, WM_USER, 0, GetTickCount);
      end;
    end;
  end;
end;

procedure TMyThread.Terminate;
begin
  PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
  inherited;
end;

destructor TMyThread.Destroy;
begin
  Terminate;
  inherited;
end;

var
  MyThread: TMyThread;

procedure TForm1.WMUser(var msg: TMessage); {message WM_USER;}
begin
  Caption := IntToStr(msg.LParam);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyThread := TMyThread.Create(False);
  MyThread.AHwnd := Handle;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PostThreadMessage(MyThread.ThreadID, WM_USER, 0, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  MyThread.Free;
end;

Register your own file extensions in the Windows registry

Problem/Question/Abstract:

I have an application that create files. I want those files to be associated to my application so that when you double click on those files will launch my application and open the particular file. How do I do this?

Answer:

Take a look at the registry (HKEY_CLASSES_ROOT) to see what exactly is possible. Basically, you have to add an entry that equals the file extension, one that equals an unique name and the action. And you have to tell Windows that you have registered a new extension. Something like:

{ ... }
var
  Regist: TRegistry;
begin
  Result
    Regist := TRegistry.Create;
  try
    Regist.RootKey := HKEY_CLASSES_ROOT;
    {file type}
    if Regist.OpenKey('.xyz' {= your extension}, True) then
    begin
      Regist.WriteString('', 'xyz-file' {= unique name});
      Regist.CloseKey;
    end;
    {name}
    if Regist.OpenKey('xyz-file' {= same unique name}, True) then
    begin
      Regist.WriteString('', 'xyz super file'
        {= short description, is shown in explorer});
      Regist.CloseKey;
    end;
    {icon}
    if Regist.OpenKey('xyz-file\DefaultIcon', True) then
    begin
      {third icon of your exe, 0 is the main icon I think, of course you can use
                        other files than Application.ExeName}
      Regist.WriteString('', Application.ExeName + ', 3');
      Regist.CloseKey;
    end;
    {open}
    if Regist.OpenKey('xyz-file\Shell\Open\Command', True) then
    begin
      Regist.WriteString('', Application.ExeName + ' "%1"');
        {or other/ additional parameters}
      Regist.CloseKey;
      Result := True;
    end;
    {you can add more for edit, print etc.}
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
    {tell Windows we have done it}
  finally
    Regist.Free;
  end;
end;

How to draw a frame around a TImage

Problem/Question/Abstract:

How to draw a frame around a TImage

Answer:

unit paintframe;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private Declarations}
  public
    procedure drawtheframe(Fwidth: Integer; colr: TColor);
    procedure Hideframe;
    procedure Showframe;
  end;

var
  Form1: TForm1;

const
  Fwidth = 2;
  There: boolean = false;

implementation

{$R *.DFM}

procedure TForm1.drawtheframe(Fwidth: Integer; colr: TColor);
var
  z: Integer;
begin
  z := ord(not (odd(Fwidth)));
  canvas.brush.style := bsClear;
  canvas.pen.width := Fwidth;
  canvas.pen.color := colr;
  Fwidth := width1 - (Fwidth div 2);
  canvas.rectangle(image1.left - Fwidth, image1.top - Fwidth, image1.left + image1.width
    + Fwidth + z, image1.top + image1.height + Fwidth + z);
end;

procedure TForm1.Showframe;
begin
  drawtheframe(Fwidth, clBlue);
  There := true;
end;

procedure TForm1.Hideframe;
begin
  There := false;
  drawtheframe(Fwidth, color);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  if There then
    Showframe;
end;

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

procedure TForm1.Button2Click(Sender: TObject);
begin
  Hideframe;
end;

end.

How to copy one TRichEdit to another

Problem/Question/Abstract:

How to copy one TRichEdit to another

Answer:

type
  TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD; stdcall;

  TEditStream = record
    dwCookie: Longint;
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
  cb: Longint; var pcb: Longint): DWORD; stdcall;
var
  theStream: TStream;
  dataAvail: LongInt;
begin
  theStream := TStream(dwCookie);
  with theStream do
  begin
    dataAvail := Size - Position;
    Result := 0; {assume everything is ok}
    if dataAvail <= cb then
    begin
      pcb := Read(pbBuff^, dataAvail);
      if pcb <> dataAvail then {couldn't read req. amount of bytes}
        result := E_FAIL;
    end
    else
    begin
      pcb := Read(pbBuff^, cb);
      if pcb <> cb then
        result := E_FAIL;
    end;
  end;
end;

function EditStreamOutCallback(dwCookie: Longint; pbBuff: PByte; cb:
  Longint; var pcb: Longint): DWORD; stdcall;
var
  theStream: TStream;
begin
  theStream := TStream(dwCookie);
  with theStream do
  begin
    if cb > 0 then
      pcb := Write(pbBuff^, cb);
    Result := 0;
  end;
end;

procedure GetRTFSelection(aRichEdit: TRichEdit; intoStream: TStream);
var
  editstream: TEditStream;
begin
  with editstream do
  begin
    dwCookie := Longint(intoStream);
    dwError := 0;
    pfnCallback := EditStreamOutCallBack;
  end;
  aRichedit.Perform(EM_STREAMOUT, SF_RTF or SFF_SELECTION, longint(@editstream));
end;

procedure PutRTFSelection(aRichEdit: TRichEdit; sourceStream: TStream);
var
  editstream: TEditStream;
begin
  with editstream do
  begin
    dwCookie := Longint(sourceStream);
    dwError := 0;
    pfnCallback := EditStreamInCallBack;
  end;
  aRichedit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, longint(@editstream));
end;

procedure InsertRTF(aRichEdit: TRichEdit; s: string);
var
  aMemStream: TMemoryStream;
begin
  if Length(s) > 0 then
  begin
    aMemStream := TMemoryStream.Create;
    try
      aMemStream.Write(s[1], length(s));
      aMemStream.Position := 0;
      PutRTFSelection(aRichEdit, aMemStream);
    finally
      aMemStream.Free;
    end;
  end;
end;

procedure CopyRTF(aSource, aDest: TRichEdit);
var
  aMemStream: TMemoryStream;
begin
  aMemStream := TMemoryStream.Create;
  try
    GetRTFSelection(aSource, aMemStream);
    aMemStream.Position := 0;
    PutRTFSelection(aDest, aMemStream);
  finally
    aMemStream.Free;
  end;
end;

Enumerate all network resources

Problem/Question/Abstract:

Enumerate all network resources

Answer:

The following routine DoEnumeration enumerates all network resources and puts the server names in a listbox ListBox1. In the given application this was used to select an application server.

function Fix(Server: string): string;
var
  p: integer;
begin { Fix }
  // dirty & slow, but it works :-)
  while copy(Server, 1, 1) = '\' do
    delete(Server, 1, 1);
  p := pos('\', Server);
  if p > 0 then
    delete(Server, p, 999);

  Result := Server
end; { Fix }

procedure TFSelServer.DoEnumeration;
type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
var
  I, Count, BufSize, Size, NetResult: Integer;
  NetHandle: THandle;
  NetResources: PNetResourceArray;
  Server: string;
begin { DoEnumeration }
  if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0, nil, NetHandle) <> NO_ERROR
    then
    Exit;

  try
    BufSize := 50 * SizeOf(TNetResource);
    GetMem(NetResources, BufSize);
    try
      while True do
      begin { while Tr.. }
        Count := -1;
        Size := BufSize;
        NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
        if NetResult = ERROR_MORE_DATA then
        begin
          BufSize := Size;
          ReallocMem(NetResources, BufSize);
          Continue;
        end;
        if NetResult <> NO_ERROR then
          Exit;
        for I := 0 to Count - 1 do
          with NetResources^[I] do
          begin { with Net.. }
            Server := Fix(lpRemoteName);
            if ListBox1.Items.IndexOf(Server) < 0 then
              ListBox1.Items.Add(Server)
          end; { with Net.. }
      end; { while Tr.. }
    finally
      FreeMem(NetResources, BufSize);
    end; { try }
  finally
    WNetCloseEnum(NetHandle);
  end; { try }
end; { DoEnumeration }

Retrieve clipboard data in RTF tokens

Problem/Question/Abstract:

I'm trying to retrieve clipboard data in RTF tokens, and I can't figure out how to do it. Here's the scenario: 1. Create rich text in (eg) WordPad, including bold, italics etc., 2. Copy that to the clipboard., 3. Paste it into a TRichEdit. The pasted data includes all the formatting info. However, if I try to get that data off the clipboard myself, using Clipboard.AsText, or getting a handle to it with CF_TEXT, what I get is plain text, minus the formatting. It seems to me there should be a way to get RTF tokens from the clipboard, but neither the Delphi docs nor the MS documentation lists any format that could include rich text. There is no such format as CF_RICHTEXT. Anybody know how I can do this? Am I completely wrong to assume that RTF tokens are even being passed through the clipboard in the above scenario?

Answer:

uses
  RichEdit;

function GetRawRTFFromClipboard: string;
var
  H: THandle;
  TextPtr: PChar;
  CurrentFormat: Integer;
  NameLen: DWord;
  NameStr: string;
begin
  Result := '';
  ClipBoard.Open;
  try
    CurrentFormat := EnumClipboardFormats(0);
    while CurrentFormat <> 0 do
    begin
      NameLen := 1024;
      SetLength(NameStr, NameLen);
      NameLen := GetClipboardFormatName(CurrentFormat, PChar(NameStr), NameLen);
      SetLength(NameStr, NameLen);
      if CompareText(NameStr, CF_RTF) = 0 then
        Break;
      CurrentFormat := EnumClipboardFormats(CurrentFormat);
    end;
    if CurrentFormat = 0 then
      raise Exception.Create('Data on clipboard is not RTF');
    H := Clipboard.GetAsHandle(CurrentFormat);
    TextPtr := GlobalLock(H);
    Result := StrPas(TextPtr);
    GlobalUnlock(H);
  finally
    Clipboard.Close;
  end;
end;

How to print a file directly to a printer

Problem/Question/Abstract:

How to print a file directly to a printer

Answer:

Solve 1:

uses
  WinSpool;

procedure PrintFile(const sFileName: string);
const
  BufSize = 16384;
type
  TDoc_Info_1 = record
    pDocName: pChar;
    pOutputFile: pChar;
    pDataType: pChar;
  end;
var
  Count, BytesWritten: integer;
  hPrinter: THandle;
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDeviceMode: THandle;
  DocInfo: TDoc_Info_1;
  f: file;
  Buffer: Pointer;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not WinSpool.OpenPrinter(@Device, hPrinter, nil) then
    exit;
  DocInfo.pDocName := 'MyDocument';
  DocInfo.pOutputFile := nil;
  DocInfo.pDatatype := 'RAW';
  if StartDocPrinter(hPrinter, 1, @DocInfo) = 0 then
  begin
    WinSpool.ClosePrinter(hPrinter);
    exit;
  end;
  if not StartPagePrinter(hPrinter) then
  begin
    EndDocPrinter(hPrinter);
    WinSpool.ClosePrinter(hPrinter);
    exit;
  end;
  System.Assign(f, sFileName);
  try
    Reset(f, 1);
    GetMem(Buffer, BufSize);
    while not eof(f) do
    begin
      Blockread(f, Buffer^, BufSize, Count);
      if Count > 0 then
      begin
        if not WritePrinter(hPrinter, Buffer, Count, BytesWritten) then
        begin
          EndPagePrinter(hPrinter);
          EndDocPrinter(hPrinter);
          WinSpool.ClosePrinter(hPrinter);
          FreeMem(Buffer, BufSize);
          exit;
        end;
      end;
    end;
    FreeMem(Buffer, BufSize);
    EndDocPrinter(hPrinter);
    WinSpool.ClosePrinter(hPrinter);
  finally
    System.Closefile(f);
  end;
end;

procedure WriteRawStringToPrinter(PrinterName: string; S: string);
var
  Handle: THandle;
  N: DWORD;
  DocInfo1: TDocInfo1;
begin
  if not OpenPrinter(PChar(PrinterName), Handle, nil) then
  begin
    ShowMessage('error ' + IntToStr(GetLastError));
    Exit;
  end;
  with DocInfo do
  begin
    pDocName := PChar('test doc');
    pOutputFile := nil;
    pDataType := 'RAW';
  end;
  StartDocPrinter(Handle, 1, ocInfo);
  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), N);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

The PrinterName parameter must be the name of the printer as it is installed. For example, if the name of the printer is "HP LaserJet 5MP" then that is what you should pass.


Solve 2:

The procedure below spools a RAW PCL file to the printer. Mainly you need to use the WritePrinter API call along with OpenPrinter.

procedure PrintPCL;
var
  Handle: THandle;
  numwrite: DWORD;
  Docinfo1: TDocInfo1;
  PrintFile, InFile, SampForm: TMemoryStream;
  buffer: array[0..4096] of char;
  HPLetter, HPLegal, NC: array[0..15] of char;
  temp: array[0..3] of char;
  FF: char;
  numread: longint;
  x: integer;
  FileName: string;
begin
  if (OpenPrinter(PrinterName, Handle, nil)) then
  begin
    FF := Chr(12);
    strcopy(HPLetter, chr(27));
    strcat(HPLetter, '&l6d66p1h2A');
    strcopy(HPLegal, chr(27));
    strcat(HPLegal, '&l6d84p4h3A');
    strcopy(NC, chr(27));
    strcat(NC, '&l');
    strcat(NC, StrPCopy(temp, InttoStr(NumCopies)));
    strcat(NC, 'X');
    try
      PrintFile := TMemoryStream.Create;
      for x := 0 to Printlist.Count - 1 do
      begin
        FileName := Copy(PrintList[x], 1, pos(',', printlist[x]) - 1);
        InFile := TMemoryStream.Create;
        InFile.LoadFromFile(FileName);
        if (Integer(filename[Length(FileName) - 1]) = 49) then
          PrintFile.Write(HPLetter, Strlen(HPLetter))
        else
          PrintFile.Write(HPLegal, Strlen(HPLegal));
        PrintFile.Write(NC, strlen(NC));
        PrintFile.CopyFrom(InFile, 0);
        InFile.Free;
        if Sample then
        begin
          try
            SampForm := TMemoryStream.Create;
            SampForm.LoadFromFile(AppPath + 'SAMPLE.PRN');
            PrintFile.Copyfrom(SampForm, 0);
          finally
            SampForm.Free;
          end;
        end;
        PrintFile.Write(FF, SizeOf(FF));
      end;
      DocInfo1.pDocName := PChar('PCLPrinter');
      DocInfo1.pOutputFile := nil;
      DocInfo1.pDataType := 'RAW';
      PrintFile.Seek(0, 0);
      StartDocPrinter(Handle, 1, @DocInfo1);
      StartPagePrinter(Handle);
      numread := 0;
      numwrite := 0;
      while (numread = numwrite) and (PrintFile.Position <> PrintFile.Size) do
      begin
        numread := PrintFile.Read(buffer, sizeof(buffer));
        WritePrinter(Handle, @buffer, numread, numwrite);
        UpdateProgress(round((PrintFile.Position / PrintFile.Size) * 100));
      end;
      EndPagePrinter(Handle);
      EndDocPrinter(Handle);
      ClosePrinter(Handle);
    finally
      PrintFile.Free;
    end;
  end;
end;

How to draw multiple columns in a TComboBox

Problem/Question/Abstract:

How to draw multiple columns in a TComboBox

Answer:

You can go with a custom drawn combo box:

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls;

type

  TDataRec = class(TObject)
  private
    Str1: string;
    Str2: string;
  end;

  TForm1 = class(TForm)
    DeleteListBox1: TListBox;
    Header1: THeader;
    Image1: TImage;
    ComboBox1: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
      State: TOwnerDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  DataRec: TDataRec;
begin
  for i := 1 to 10 do
  begin
    DataRec := TDataRec.Create;
    with DataRec do
    begin
      Str1 := 'String1 ' + IntToStr(i);
      Str2 := 'String2 ' + IntToStr(i);
    end;
    ComboBox1.Items.AddObject('', DataRec);
  end;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  S1, S2: string;
  TempRect: TRect;
begin
  S1 := TDataRec(ComboBox1.Items.Objects[Index]).Str1;
  S2 := TDataRec(ComboBox1.Items.Objects[Index]).Str2;
  ComboBox1.Canvas.FillRect(Rect);
  TempRect := Rect;
  TempRect.Right := Header1.SectionWidth[0];
  ComboBox1.Canvas.StretchDraw(TempRect, Image1.Picture.Graphic);
  Rect.Left := Rect.Left + 50;
  DrawText(ComboBox1.Canvas.Handle, PChar(S1), Length(S1), Rect, dt_Left or dt_VCenter);
  Rect.Left := Rect.Left + 100;
  DrawText(ComboBox1.Canvas.Handle, PChar(S1), Length(S1), Rect, dt_Left or dt_VCenter);
end;

end.

Distributable COM Objects on Remote Machines

Problem/Question/Abstract:

Distributable COM Objects on Remote Machines

Answer:

There is not much documentation around on DCOM. DCOM is similar to COM except that the objects reside and are registered on remote machines.

In this article I demonstrate how to connect to and execute remote COM objects (your own or 3rd party). The objects must support the IDISPATCH interface (majority do).

Those of you familiar with the function CreateOleObject() will be quite comfortable with the approach, others can search the Internet for "COM" articles to clarify this technique.

The Windows DCOMCNFG.EXE, which allows permission and properties to be maintained by the remote machine is also discussed.

The article was written using platforms Delphi 5 and Win2000. I do not know if this approach works on lesser versions as I do not have access to them..


The function commonly used to connect to COM/OLE objects is CreateOleObject().
eg. Ole := CreateOleObject(&#8216;word.application&#8217;);

The connection to a DCOM object is not that different in concept except that we use the GUID of the object class instead of the Classname string, CreateComObject() also uses the GUID.

The function we use to implement DCOM in Delphi is CreateRemoteComObject(), which resides in unit ComObj.

Definition
function CreateRemoteComObject(const MachineName: WideString;
                               const ClassID: TGUID): IUnknown;

The MachineName is a string of the Target machine that you want to run the Object on.

eg.  &#8216;mheydon&#8217;

The ClassID is the GUID of the object that is found in the registry under key HKEY_LOCAL_MACHINE\Software\CLSID.

eg. const PUNK : TGUID = '{000209FF-0000-0000-C000-000000000046}';

Refer to my article &#8220;COM/OLE Object Name Utility Procedure &#8221; for an easy way to browse for these GUIDs

The function (if successful) returns an IUNKNOWN interface. We require an IDISPATCH interface, thus we will simply use Delphi&#8217;s typecasting feature.

A trivial example of a user written COM/OLE application is as follows. The method BirthDate() simply returns a string containing the birthdate of the given age in years from the target machine.



uses ComObj;

// GUID of my test object &#8216;serv.server&#8217;
const
  PUNK: TGUID = '{74A5EC07-DC84-4C65-8944-1A2315A550FB}';

procedure TForm1.Button1Click(Sender: TObject);
var
  Ole: OleVariant;
  BDate: WideString;
begin
  // Create the object as IDISPATCH
  Ole := CreateRemoteComObject('mheydon', PUNK) as IDispatch;

  Ole.BirthDate(46, BDate); // Method of 'serv.server'
  showmessage(BDate);

  Ole := VarNull; // Free object and deactivate
end;


As you can see it is a very simplified example (without error checking), but the prime objective was to display the DCOM connectivity in a clear way.


The other thing that affects the DCOM object on the target machine is permissions and other properties. If you are getting &#8220;Access Denied&#8221; or want to change the behaviour of the remote object then run the Windows utility DCOMCNFG.EXE. This has many options and a summary is as follows.


Main form. Select your object here and set it&#8217;s properties. Be careful if playing with any of the DEFAULT tabs as they will affect ALL your objects.

General. All you change here is Authentication level. Not sure what affects all the different options have.

Location. Where to run the application.

Security. If you are getting Access Denied errors when connecting then you can modify or add users here.

Identity. This is similar to setting the user of a Windows Service. If you want to be able to kill the process from task manager then you should set this option to &#8220;This users&#8221; where the user is the current user of the machine, or else task manager will tell you that you have no permissions to kill the process.

Endpoints. Have absolutely no idea what this page does. Some light anyone ?

How to save and restore font properties in the registry (2)

Problem/Question/Abstract:

I was just wondering what the best way to save a particular font to the registry would be. Do I have to save each of its attributes separately? Is there an easier way than storing it to the registry, perhaps? Seems like such a simple issue, but other than saving and loading each attribute separately, I can't think of a way to do it at one time!

Answer:

You can do it by getting a TLogfont record filled and save that to a binary key:


var
  lf: TLogfont;
begin
  fillchar(lf, sizeof(lf), 0);
  GetObject(font.handle, sizeof(lf), @lf);
  registry.WriteBinarydata(valuename, lf, sizeof(lf));
end;


Reading it back would go like this:


registry.ReadBinarydata(valuename, lf, sizeof(lf));
font.handle := CreateFontIndirect(lf);


A probably more Kylix-compatible method would be to create a non-visual wrapper component for a TFont and stream that, e.g. to a memory stream. The streams content could then be saved to a binary registry key.


type
  TFontWrapper = class(TComponent)
  private
    FFont: TFont;
    procedure SetFont(f: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Font: TFont read FFont write SetFont;
  end;

constructor TFontWrapper.Create(AOwner: TComponent);
begin
  inherited Create(aOwner);
  FFont := TFont.Create;
end;

destructor TFontWrapper.Destroy;
begin
  FFont.Free;
  inherited Destroy;
end;

procedure TFontWrapper.SetFont(f: TFont);
begin
  FFont.Assign(f);
end;

procedure TScratchMain.SpeedButton2Click(Sender: TObject);
const
  b: Boolean = False;
var
  fw: TFontWrapper;
  st: TFileStream;
begin
  if b then
  begin
    edit1.text := 'Loading font';
    fw := nil;
    st := TFileStream.Create('E:\A\test.str', fmOpenRead);
    try
      fw := TFontWrapper.Create(nil);
      st.ReadComponent(fw);
      memo1.font.assign(fw.font);
    finally
      fw.Free;
      st.Free;
    end;
  end
  else
  begin
    edit1.text := 'Saving font';
    fw := nil;
    st := TFileStream.Create('E:\A\test.str', fmCreate);
    try
      fw := TFontWrapper.Create(nil);
      fw.Font := Font;
      st.WriteComponent(fw);
    finally
      fw.Free;
      st.Free;
    end;
  end;
  b := not b;
end;

How to use a loop to catch edit control values

Problem/Question/Abstract:

I want to check if the user has filled all required DBEdit controls on a notebook, before enabling a button on the form.

Answer:

If you dropped the controls onto the notebook at design time, their Owner will be the form not the notebook. This means that it will not belong to the Components array of the notebook, but of the form. The Notebook's Controls array will be all the controls it parents and that is probably the array you want to loop through.

procedure TAddFrm.SetNextBtn;
var
  I: Integer;
  fld: TControl;
  fldEmpty: Boolean;
begin
  fldEmpty := False;
  with Notebook do
  begin
    for I := 0 to ControlCount - 1 do
    begin
      fld := Controls[i];
      if (fld is TDBEdit) then
      begin
        fldEmpty := TDBEdit(fld).GetTextLen = 0;
        if fldEmpty then
          Break;
      end
    end;
    AddfrmNextBtn.Enabled := not fldEmpty;
  end;
end;

if fldName is TCustomEdit then
  fldEmpty := TCustomEdit(fldName).GetTextLen = 0;

How to rotate a 2D point

Problem/Question/Abstract:

How to rotate a 2D point

Answer:

In 2-D, the 2 x 2 matrix is very simple. If you want to rotate a column vector v by t degrees using matrix M, use



M = {{cos t, -sin t}, {sin t, cos t}}



in M * v.

If you have a row vector, use the transpose of M (turn rows into columns and vice versa). If you want to combine rotations, in 2-D you can just add their angles, but in higher dimensions you must multiply their matrices.