XML DOM Parser in Delphi 6

Problem/Question/Abstract:

How to parse an XML File/String in Delphi?

Answer:

This is relevance to my previous article Importing XML DOM Parser Into Delphi....

In Delphi 6, there is a separate component to do the XML parsing in the Internet Palette, called TXMLDocument. With this component, we dont need to do any import like I mentioned in that article. The only thing you need is that you should have the relevant DLLs in your machine to do the parsing like MSXML.dll(Microsoft parser). You can use any parser as you wish.

Now let us quickly review the properties and methods of this component.

DOMVendor

It’s a drop-down list containing the parsers available in your machine. If you have MSXML.dll in your machine, then you will see MSXML in that drop-down list. It’s nothing but the Microsoft parser. Like that if you have other parsers, then those will also be listed there. You can choose one.

File Name or XML strings

You can either pass in a XML file or an XML string to that component.

XMLDocument1.FileName := 'sample.xml'
XMLDocument1.XML.strings.add('an xml string');

Once you set these two properties, you can set the Active property to true; this initiates the parsing. Any errors during parsing will be captured by the Delphi’s EDOMParseError exception.

Also, you can save the XML document or strings into a separate file or memory stream.

XMLDocument1.SaveToFile('File Name');
XMLDocument1.SaveToStream(MemoryStream);

Getting the XML Data

Once the XML has been parsed without any parsing errors, you can get node details by using the method getElementsByTagName and properties like NodeName, NodeValue, NodeType etc.,

As I mentioned in that article, the DTD file should be in the search path as the application or should be in the path where the exe resides. Also you have to make sure that the XML file or string you are parsing should follow the DTDs mentioned in that DTD file.

A simple File Comparison Utility

Problem/Question/Abstract:

Sometimes you are only interested in knowing if two files are the same- you might have hit return a few times in the editor so one looks bigger than the other and has a later save date but it might be the same otherwise...

Answer:

The utility listed below (both .pas and .dfm source) accepts as input two file names. For convenience these filenames (with associated paths) are saved out between runs and you can copy the filename from the first box to the second (click the red down arrow) - it combines the first filename with the existing 2nd path.  Both edit boxes allow you to browse for files.

File comparison is simple and fast. Each file is read into a memory stream and then a count of each of the 256 possible characters is made. You could argue that by cutting and moving text elsewhere in a text file file that this would break my method (as char counts would be unaffected) and you'd be right but I think for most purposes this method is probably sufficient and it works with binary as well as text files. I realise a CRC calculation could also be added- feel free to do so.

When there are differences the output is a string showing each character value (0-255) followed by the count in brackets.

For something thrown together quickly in an hour or so, it has served me well and compares files of a few megabytes pretty quickly.

Pascal Source

unit viewdiff;

interface

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

type
  TDBDiff = class
    Ffilename1: string;
    FfileName2: string;
    FBuff1: TmemoryStream;
    FBuff2: TmemoryStream;
    FCounts1: array[0..255] of integer;
    FCounts2: array[0..255] of integer;
    FProcessed: boolean;
    fDifferenceStr: string;
    FDifferent: boolean;
  private

    function GetDiffCount(ch: char): integer;
    function GetDifferences: boolean;
    procedure Clear;
    procedure BuildDiffTable(Mem1, Mem2: pointer; size1, size2: integer);
    procedure BuildDifferenceStr;
    function CheckIfSame: boolean;
  public
    constructor Create;
    destructor Destroy; override;
    property Different: boolean read GetDifferences;
    property DifferenceStr: string read fDifferenceStr;
    property DiffCount[ch: char]: integer read GetDiffCount;
    property Filename1: string read FFilename1 write FFilename1;
    property Filename2: string read FFilename2 write FFilename2;
  end; // TdbDiff

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    fileopen: TOpenDialog;
    Edit1: TEdit;
    Edit2: TEdit;
    GoBtn: TButton;
    btnCopyDown: TBitBtn;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure GoBtnClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnCopyDownClick(Sender: TObject);
  private
    procedure CheckGoBtn;
    procedure LoadEditBoxes;
    procedure SaveEditBoxes;
    { Private declarations }
  public
    { Public declarations }
    Aftercreate: boolean;
    Diff: tDbDiff;
    StartPath: string;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  editsavefilename = 'diff.ini';
  CrLf = #13#10;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Edit1.Text <> '' then
    FileOpen.Initialdir := ExtractFileDir(Edit1.Text);
  if FileOpen.execute then
    edit1.Text := FileOpen.Filename;
  CheckGobtn;
end;

procedure Tform1.checkGoBtn;
var
  filename: string;
begin
  Gobtn.enabled := false;
  Filename := trim(Edit1.Text);
  if (Filename <> '') and fileexists(Filename) then
  begin
    Filename := trim(Edit2.Text);
    if (Filename <> '') and fileexists(Filename) then
      GoBtn.Enabled := True;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if Edit2.Text <> '' then
    FileOpen.Initialdir := ExtractFileDir(Edit2.Text);
  if FileOpen.execute then
    edit2.Text := FileOpen.Filename;
  CheckGoBtn;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Aftercreate := true;
end;

{ TDBDiff }

procedure TdbDiff.Clear;
begin
  fFilename1 := '';
  fFilename2 := '';
  fillchar(fCounts1, sizeof(fcounts1), 0);
  fillchar(fCounts2, sizeof(fcounts2), 0);
  fDifferenceStr := '';
  fProcessed := false;
end;

constructor TDBDiff.Create;
begin
  fBuff1 := TmemoryStream.Create;
  fBuff2 := TmemoryStream.Create;
  Clear;
end;

destructor TDBDiff.Destroy;
begin
  FBuff2.Free;
  FBuff1.Free;
end;

function TDBDiff.GetDiffCount(ch: char): integer;
begin
  result := fCounts1[ord(ch)] - Fcounts2[ord(ch)];
end;

procedure TdbDiff.BuildDifferenceStr;
var
  Index: integer;
begin
  fDifferenceStr := '';
  for Index := 0 to 255 do
    if fcounts1[Index] <> fCounts2[Index] then
    begin
      fDifferenceStr := fDifferencestr +
        ' #' + inttostr(Index) + '(' + inttostr(fcounts1[Index] - Fcounts2[Index]) +
          ')';
    end;
end;

function TDBDiff.CheckIfSame: boolean;
var
  Index: integer;
begin
  result := true;
  for Index := 0 to 255 do
    if fcounts1[Index] <> fcounts2[Index] then
    begin
      Result := false;
      exit;
    end;
end;

procedure TDBDiff.BuildDiffTable(mem1, mem2: pointer; size1, size2: integer);
type
  Bytemap = array[0..2000000000] of byte;
  BytemapPtr = ^ByteMap;
var
  MapPtr: ByteMapPtr;
  Index: integer;
begin
  MapPtr := ByteMapPtr(mem1);
  for Index := 0 to size1 - 1 do
    inc(fcounts1[MapPtr^[Index]]);
  MapPtr := ByteMapPtr(mem2);
  for Index := 0 to size2 - 1 do
    inc(fcounts2[MapPtr^[Index]]);
end;

function TDBDiff.GetDifferences: boolean;
var
  fs: TFileStream;
begin
  if fProcessed then
    Result := Fdifferent
  else
  begin
    Result := false;
    if (trim(Ffilename1) = '') or (trim(FFilename2) = '') then
      exit;
    fProcessed := true;
    fs := TfileStream.Create(fFilename1, fmOpenRead);
    fbuff1.LoadFromStream(fs);
    fs.free;
    fs := TfileStream.Create(fFilename2, fmOpenRead);
    fbuff2.LoadFromStream(fs);
    fs.free;
    BuildDiffTable(fbuff1.memory, fbuff2.memory, fbuff1.size, fbuff2.size);
    BuildDifferenceStr;
    Result := not CheckIfSame;
  end;
end;

procedure TForm1.GoBtnClick(Sender: TObject);

begin
  diff.Clear;
  diff.Filename1 := edit1.text;
  diff.Filename2 := edit2.text;
  if diff.Different then
    ShowMessage(
      'Differences between ' + Crlf +
      diff.Filename1 + Crlf +
      diff.Filename2 + Crlf + Crlf +
      diff.DifferenceStr)
  else
    ShowMessage('Files identical');
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  if AfterCreate then
  begin
    AFterCreate := false;
    diff := tdbdiff.Create;
    GetDir(0, StartPath);
    if StartPath[Length(StartPath)] <> '\' then
      StartPath := StartPath + '\';
    LoadEditBoxes;
  end;
end;

procedure Tform1.LoadEditBoxes;
var
  tf: textfile;
  s: string;
begin
  if fileexists(StartPath + EditSaveFilename) then
  begin
    assignfile(tf, StartPath + EditSavefilename);
    reset(tf);
    try
      readln(tf, s);
      edit1.text := s;
      readln(tf, s);
      edit2.text := s;
    finally
      Closefile(Tf);
      CheckGoBtn;
    end;
  end;
end;

procedure Tform1.SaveEditBoxes;
var
  tf: textfile;
  s: string;
begin
  assignfile(tf, StartPath + EditSavefilename);
  rewrite(tf);
  try
    s := edit1.text;
    writeln(tf, s);
    s := edit2.text;
    writeln(tf, s);
  finally
    Closefile(Tf);
  end;
end;

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

procedure TForm1.btnCopyDownClick(Sender: TObject);
begin
  edit2.text := ExtractFileDir(Edit2.Text) + '\' +
    ExtractFileName(Edit1.Text);
end;

end.

DFM Source

object Form1: TForm1
  Left = 338
    Top = 555
    Width = 462
    Height = 172
    Caption = 'Difference Utility'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    OnActivate = FormActivate
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    PixelsPerInch = 96
    TextHeight = 13
    object Button1: TButton
    Left = 12
      Top = 30
      Width = 75
      Height = 25
      Caption = '1st File'
      TabOrder = 0
      OnClick = Button1Click
  end
  object Button2: TButton
    Left = 12
      Top = 78
      Width = 75
      Height = 25
      Caption = '2nd File'
      TabOrder = 1
      OnClick = Button2Click
  end
  object Edit1: TEdit
    Left = 96
      Top = 30
      Width = 343
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 2
  end
  object Edit2: TEdit
    Left = 96
      Top = 78
      Width = 343
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 3
  end
  object GoBtn: TButton
    Left = 96
      Top = 114
      Width = 75
      Height = 25
      Caption = 'Compare'
      Enabled = False
      TabOrder = 4
      OnClick = GoBtnClick
  end
  object btnCopyDown: TBitBtn
    Left = 240
      Top = 54
      Width = 26
      Height = 23
      TabOrder = 5
      OnClick = btnCopyDownClick
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    0400000000000001000000000000000000001000000010000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333303333
    333333333337F33333333333333033333333333333373F333333333333090333
    33333333337F7F33333333333309033333333333337373F33333333330999033
    3333333337F337F33333333330999033333333333733373F3333333309999903
    333333337F33337F33333333099999033333333373333373F333333099999990
    33333337FFFF3FF7F33333300009000033333337777F77773333333333090333
    33333333337F7F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333300033333333333337773333333}
    NumGlyphs = 2
  end
  object fileopen: TOpenDialog
    DefaultExt = '*'
      Filter = 'Any File|*.*'
      Left = 354
  end
end

Interbase Backup on the Fly in a thread

Problem/Question/Abstract:

In the Interbase Admin components there is a IBBackupService but is hard to use as it is. This component makes this alot easier, and also works in a thread.

Answer:

(*
  Interbase Backup Thread

  Author
    Kim Sandell
    Email: kim.sandell@nsftele.com

  Description
    A Thread that performs an backup of an interbase database on the fly.

  Version
    1.0

  History
    23.09.2002  - Initial version

  Known issues
    None so far ...

  Example of usage

    The example below assumes you have included the "IBBackupThread" unit
    in the uses clause, and that you have a button on a form.

    The example makes 10 fragments, each max 4 Megabytes. If the backup
    is larger, the last (10th fragment) will be bigger than 4 Megs.

    procedure TForm1.Button1Click(Sender: TObject);
    Var
       IBB: TIBBackupThread;
    begin
         IBB := NIL;
         Try
            IBB := TIBBackupThread.Create(True);
            IBB.Initialize;
            IBB.BackupPath := 'C:\Databases';
            IBB.DatabaseName := '127.0.0.1:C:\Databases\MyIBDB.GDB';
            IBB.DatabaseUsername := 'SYSDBA';
            IBB.DatabasePassword := 'masterkey';
            IBB.Fragments := 4;
            IBB.FragmentSizeK := 4096;
            IBB.Resume;
            While Not IBB.Terminated do
            Begin
                 SleepEx(1,True);
                 Application.ProcessMessages;
            End;
            IBB.WaitForAndSleep;
            If IBB.Success then
            Begin
                 MessageDlg('Backup OK',mtInformation,[mbOK],0);
                 ShowMessage( IBB.BackupLog.Text );
            End Else MessageDlg('Backup FAILED',mtError,[mbOK],0);
         Finally
            IBB.Free;
         End;
    end;
*)
unit IBBackupThread;

interface

uses
  Windows, Messages, SysUtils, Classes,
  IB, IBServices;

type
  TIBBackupThread = class(TThread)
  private
    { Private declarations }
  protected
    { Protected declarations }
    function BackupDatabase: Boolean;
  public
    { Public declarations }
    BackupOptions: TBackupOptions; // Backup Options
    BackupLog: TStringList; // A Stringlist with the results of the backup
    BackupPath: string; // Path on server
    DatabaseName: string; // Fully qualifyed name to db
    DatabaseUsername: string; // Username
    DatabasePassword: string; // Password
    Fragments: Cardinal; // How many backup files. 0 means 1 file.
    FragmentSizeK: Cardinal; // Max Size of a backup fragment in KByte
    Success: Boolean; // After operation, indicates Success or Fail

    property Terminated; // Make the Terminated published

    { Methods }
    procedure Initialize;
    destructor Destroy; override;
    procedure Execute; override;
    procedure WaitForAndSleep; // Special WaitFor that does not take 100% CPU
  published
    { Published declarations }
  end;

implementation

{ TIBBackupThread }

procedure TIBBackupThread.Initialize;
begin
  { Create variables }
  BackupLog := TStringList.Create;
  { Initialize default values }
  BackupPath := '';
  DatabaseName := '';
  DatabaseUsername := 'SYSDBA';
  DatabasePassword := '';
  Fragments := 0;
  FragmentSizeK := 0;
  Success := False;
  { Default to no options }
  BackupOptions := [];
end;

destructor TIBBackupThread.Destroy;
begin
  try
    { Free the result list }
    if Assigned(BackupLog) then
      BackupLog.Free;
  finally
    inherited;
  end;
end;

procedure TIBBackupThread.WaitForAndSleep;
var
  H: THandle;
  D: DWord;
begin
  { Get Handle }
  H := Handle;
  { Wait for it to terminate }
  repeat
    D := WaitForSingleObject(H, 1);
    { System Slizes }
    SleepEx(1, True);
  until (Terminated) or ((D <> WAIT_TIMEOUT) and (D <> WAIT_OBJECT_0));
end;

procedure TIBBackupThread.Execute;
begin
  try
    { Do not free it on termination }
    FreeOnTerminate := False;
    { Set lower priority }
    Priority := tpLower; // tpXXXXX variables
    try
      Success := BackupDatabase;
    finally
    end;
  except
  end;
  { Signal the termination of the Thread }
  Terminate;
end;

function TIBBackupThread.BackupDatabase: Boolean;
var
  IBBack: TIBBackupService;
  SrvAddr: string;
  DBPath: string;
  BakPath: string;
  BakName: string;
  I: Integer;

  { Leading Zero function }
  function Lz(Value: Cardinal; Digits: Byte): string;
  begin
    Result := IntToStr(Value);
    while Length(Result)
  end;

begin
  { Default Result }
  Result := False;
  try
    { Clear log }
    BackupLog.Clear;
    { Initialize Values }
    IBBack := nil;
    { Extract SrvAddr and DBPath from DatabaseName }
    BakPath := IncludeTrailingPathDelimiter(BackupPath);
    SrvAddr := DatabaseName;
    { Correct if Local machine }
    if Pos(':', SrvAddr) <> 0 then
    begin
      Delete(SrvAddr, Pos(':', SrvAddr), Length(SrvAddr));
      DBPath := DatabaseName;
      Delete(DBPath, 1, Pos(':', DBPath));
    end
    else
    begin
      { Must be localhost since Server Address is missing }
      SrvAddr := '127.0.0.1';
      DBPath := DatabaseName;
    end;
    { Make sure the Fragments & Size are is OK }
    if FragmentSizeK = 0 then
      Fragments := 0;
    if Fragments > 999 then
      Fragments := 999;
    if Fragments = 0 then
      FragmentSizeK := 0;
    try
      { Create the Backup service component }
      IBBack := TIBBackupService.Create(nil);
      IBBack.Protocol := TCP;
      IBBack.LoginPrompt := False;
      IBBack.Params.Values['user_name'] := DatabaseUsername;
      IBBack.Params.Values['password'] := DatabasePassword;
      IBBack.ServerName := SrvAddr;
      IBBack.DatabaseName := DBPath;
      IBBack.Options := BackupOptions;
      IBBack.Active := True;
      try
        IBBack.Verbose := True;
        { Add the Backup filenames }
        for I := 0 to Fragments do
        begin
          { Create the Backup filename }
          BakName := ExtractFileName(DBPath);
          Delete(BakName, Pos('.', BakName), Length(BakName));
          BakName := IncludeTrailingPathDelimiter(BackupPath) + BakName;
          { Check if we need to make a fragment file }
          if I = 0 then
          begin
            BakName := BakName + '_' + FormatDateTime('YYYYMMDD_HHNNSS', Now) +
              '.gbk';
            if (FragmentSizeK > 0) then
              BakName := BakName + ' = ' + IntToStr(FragmentSizeK * 1024);
          end
          else
          begin
            BakName := BakName + '_' + FormatDateTime('YYYYMMDD_HHNNSS', Now) + '.gbk_'
              + Lz(I, 3);
            if (FragmentSizeK > 0) then
              BakName := BakName + ' = ' + IntToStr(FragmentSizeK * 1024);
          end;
          { Add the Bakup name to the Filelist }
          IBBack.BackupFile.Add(BakName);
        end;
        { Start the Service }
        IBBack.ServiceStart;
        { Get the Resulting Report Lines }
        while not IBBack.Eof do
        begin
          BackupLog.Append(IBBack.GetNextLine);
          Sleep(1);
        end;
      finally
        { Turn the Backup service off }
        IBBack.Active := False;
      end;
      { Return results }
      Result := True;
    finally
      if Assigned(IBBack) then
      begin
        IBBack.Active := False;
        IBBack.Free;
      end;
    end;
  except
    on E: Exception do
      ; // Log error here
  end;
end;

end.

Get the path of the current folder in a TVirtualExplorerListview

Problem/Question/Abstract:

How can I get the Path of the current folder? With the ComboBox I can use *.path but the path property doesn't exist in VEL.

Answer:

Solve 1:

Do you mean the folder that the files listed are in?

{ ... }
Path := RootFolderNamespace.NameForParsing;


Solve 2:

function CurrentPath: string;
var
node: PVirtualNode;
nameSpace: TNameSpace;
begin
node := VET.GetFirstSelected;
if node <> nil then
begin
VET.ValidateNamespace(node, nameSpace);
Result := NameSpace.FileSystem;
end;
end;

Lock a CD-ROM drive

Problem/Question/Abstract:

How can I prevent a CD from being ejected from a CD-ROM drive through code?

Answer:

Solve 1:

The code below only works with Windows NT 4, 2000 and XP:

{NTStyle}

function CTL_Code(DeviceType, _Function, Method, Access: Integer): DWord;
begin
Result := (DeviceType shl 16) or (Access shl 14) or (_Function shl 2) or Method;
end;

type
TPreventMediaRemoval = packed record
PreventMediaRemoval: Boolean;
end;

const
METHOD_BUFFERED = 0;
FILE_READ_ACCESS = 1;
IOCTL_STORAGE_BASE = $2D;
IOCTL_STORAGE_MEDIA_REMOVAL_FUNCTION = $201;

procedure NTStyleTrayLock(Drive: Char; Lock: Boolean);
var
Device: THandle;
IOCTL_STORAGE_MEDIA_REMOVAL: DWord;
BytesReturned: Cardinal;
InBuffer: TPreventMediaRemoval;
begin
IOCTL_STORAGE_MEDIA_REMOVAL := CTL_Code(IOCTL_STORAGE_BASE,
IOCTL_STORAGE_MEDIA_REMOVAL_FUNCTION,
METHOD_BUFFERED, FILE_READ_ACCESS);

Device := CreateFile(PChar(Format('\\.\%s:', [UpCase(Drive)])), GENERIC_ALL,
FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
if Device = INVALID_HANDLE_VALUE then
RaiseLastWin32Error;
try
InBuffer.PreventMediaRemoval := Lock;
Win32Check(DeviceIoControl(Device, IOCTL_STORAGE_MEDIA_REMOVAL, @InBuffer,
sizeof(InBuffer), nil, 0, BytesReturned, nil));
finally
FileClose(Device);
end;
end;

{UI (here: Drive W:)}

procedure TForm1.btnLockClick(Sender: TObject);
begin
NTStyleTrayLock('W', True);
end;

procedure TForm1.btnUnLockClick(Sender: TObject);
begin
NTStyleTrayLock('W', False);
end;


Solve 2:

{ ... }
type
TPREVENT_MEDIA_REMOVAL = packed record
PreventMediaRemoval: LongBool;
end;

const
IOCTL_STORAGE_MEDIA_REMOVAL = $002D4804;

procedure PreventEjection(Drive: char; Prevent: Boolean);
var
DeviceName: string;
Device: THandle;
b: Boolean;
BufIn: TPREVENT_MEDIA_REMOVAL;
BytesReturned: DWORD;
begin
DeviceName := '\\.\' + Drive + ':';
Device := CreateFile(PChar(DeviceName), GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if Device <> INVALID_HANDLE_VALUE then
begin
BufIn.PreventMediaRemoval := Prevent;
b := DeviceIOControl(Device, IOCTL_STORAGE_MEDIA_REMOVAL, @BufIn,
SizeOf(BufIn), nil, 0, BytesReturned, nil);
CloseHandle(Device);
if not b then
RaiseLastWin32Error;
end;
end;

Copy an image and text to the clipboard at the same time

Problem/Question/Abstract:

How to copy an image and text to the clipboard at the same time

Answer:

The clipboard can have multiple items in different formats on it. However, you need to add the various items to the clipboard using API functions rather than the Delphi object wrappers. The Delphi wrappers assume they are the only item on the clipboard and clear everything else off. The following shows one way to put both a bitmap and text on the clipboard.

{ ... }
var
lBmpFmt: TBMPExportFormat;
lTmpBmp: Graphics.TBitmap;
lData: THandle;
lFormat: Word;
lPalette: HPALETTE;
lTxtFmt: TSeriesDataText;
Data: THandle;
DataPtr: Pointer;
lTxt: PChar;
begin
Clipboard.Open;
try
{Make sure the clipboard is cleared every time. Someone may have put some
other formats on it that hide the things we're going to put on it (since
there's a search protocol for appropriate types and our types may be lower
in the protocol and so not be found when it comes time to paste).}
Clipboard.Clear;
{Save as a bitmap}
lBmpFmt := TBMPExportFormat.Create;
try
lBmpFmt.Panel := Self;
lTmpBmp := lBmpFmt.Bitmap;
try
lPalette := 0;
lTmpBmp.SaveToClipboardFormat(lFormat, lData, lPalette);
SetClipboardData(lFormat, lData);
if lPalette <> 0 then
SetClipboardData(CF_PALETTE, lPalette);
finally
lTmpBmp.Free;
end;
finally
lBmpFmt.Free;
end;
{Save as text}
lTxtFmt := TSeriesDataText.Create(Self);
try
lTxt := PChar(lTxtFmt.AsString);
finally
lTxtFmt.Free;
end;
Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, StrLen(lTxt) + 1);
try
DataPtr := GlobalLock(Data);
try
Move(lTxt^, DataPtr^, StrLen(lTxt) + 1);
if SetClipboardData(CF_TEXT, Data) = 0 then
ShowMessage(SysErrorMessage(GetLastError));
finally
GlobalUnlock(Data);
end;
except
GlobalFree(Data);
raise;
end;
finally
Clipboard.Close;
end;
end;

How to truncate a long directory path

Problem/Question/Abstract:

I want to draw a directory path on a canvas, but then I have a fixed width for the canvas. So I would like to truncate long directory names to fit in the canvas like
"C:\Directory1\Directory2\Directory3\Directory4\Aaahhh\Finally" should be truncated to "C:\...\Aaahhh\Finally" or "C:\...\Finally" depending on width available.

Answer:

procedure DrawPath(ACanvas: TCanvas; const Path: string; Rect: TRect);
begin
  DrawText(ACanvas.Handle, PChar(Path), -1, Rect, DT_PATH_ELLIPSIS);
end;

How to repaint a TPaintBox without erasing the background

Problem/Question/Abstract:

How can I repaint a TPaintBox object without erasing the background. I have to repaint a bitmap object and some lines every second. Just invalidating and/ or calling the repaint method of the TPaintBox results in a redraw, that's right; but I get a flicker everytime, because the background will be erased (e.g. the old bitmap) and afterwards the new one will be drawn.

Answer:

There are two techniques that spring to mind. Try the following:

procedure TForm1.FormCreate(Sender: TObject);
begin
  PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csOpaque];
end;

It will prevent the area of the form behind the paint box from being redrawn when the paint box is invalidated.

If this is not enough, you can use a "cracker" class to force the paint routine without an invalidate. Using a double buffer will prevent flicker. Here's an example:

TForm1 = class(TForm)
  Button1: TButton;
  Button2: TButton;
  PaintBox1: TPaintBox;
  procedure Button1Click(Sender: TObject);
  procedure Button2Click(Sender: TObject);
  procedure PaintBox1Paint(Sender: TObject);
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
private
  FDoubleBuffer: TBitmap;
end;

type
  TPaintBoxCracker = class(TPaintBox);

procedure TForm1.Button1Click(Sender: TObject);
begin
  with FDoubleBuffer.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(Rect(0, 0, FDoubleBuffer.Width, FDoubleBuffer.Height));
    Pen.Color := clBlue;
    MoveTo(FDoubleBuffer.Width, FDoubleBuffer.Height);
    LineTo(0, 0);
  end;
  TPaintBoxCracker(PaintBox1).Paint;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  with FDoubleBuffer.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(Rect(0, 0, FDoubleBuffer.Width, FDoubleBuffer.Height));
    Pen.Color := clRed;
    MoveTo(0, 0);
    LineTo(FDoubleBuffer.Width, FDoubleBuffer.Height);
  end;
  TPaintBoxCracker(PaintBox1).Paint;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Draw(0, 0, FDoubleBuffer);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csOpaque];
  FDoubleBuffer := TBitmap.Create;
  FDoubleBuffer.Width := PaintBox1.Width;
  FDoubleBuffer.Height := PaintBox1.Height;
end;

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

How to redirect output from a console to a GUI application

Problem/Question/Abstract:

Does anyone have a working example of a GUI application that redirects the screen output from a console application? I've tried it using the CreateProcess API function, however it only works for me when I launch it through the D5 UI, but not when I double click the compiled executable.

Answer:

unit consoleoutput;

interface

uses
  Controls, Windows, SysUtils, Forms;

function GetDosOutput(const CommandLine: string): string;

implementation

function GetDosOutput(const CommandLine: string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of Char;
  BytesRead: Cardinal;
  WorkDir, Line: string;
begin
  Application.ProcessMessages;
  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  {create pipe for standard output redirection}
  CreatePipe(StdOutPipeRead, {read handle}
    StdOutPipeWrite, {write handle}
    @SA, {security attributes}
    0 {number of bytes reserved for pipe - 0 default}
    );
  try
    {Make child process use StdOutPipeWrite as standard out, and
    make sure it does not show on screen}
    with SI do
    begin
      FillChar(SI, SizeOf(SI), 0);
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE); {don't redirect stdinput}
      hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;
    {launch the command line compiler
    WorkDir := 'C:\';}
    WorkDir := '';
    WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, nil, SI,
      PI);
    Now that the handle has been inherited, close write to be safe.We don't
      want to read or write to it accidentally}
      CloseHandle(StdOutPipeWrite);
    {if process could be created then handle its output}
    if not WasOK then
      raise Exception.Create('Could not execute command line!')
    else
    try
      {get all output until DOS app finishes}
      Line := '';
      repeat
        {read block of characters (might contain carriage returns and line feeds)}
        WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
        {has anything been read?}
        if BytesRead > 0 then
        begin
          {finish buffer to PChar}
          Buffer[BytesRead] := #0;
          {combine the buffer with the rest of the last run}
          Line := Line + Buffer;
        end;
      until
        not WasOK or (BytesRead = 0);
      {wait for console app to finish (should be already at this point)}
      WaitForSingleObject(PI.hProcess, INFINITE);
    finally
      {Close all remaining handles}
      CloseHandle(PI.hThread);
      CloseHandle(PI.hProcess);
    end;
  finally
    result := Line;
    CloseHandle(StdOutPipeRead);
  end;
end;

end.

Save a TJEPGImage with DPI information

Problem/Question/Abstract:

I need to save a JPEG with DPI information, but cannot find a PPI or DPI property to set. I know that .JPG headers include horizontal and vertical DPI information, but cannot find a correponding property in Delphi 6's TJPEGImage object. Does anyone know how to do this?

Answer:

procedure SetJpgdpi(filename: string; dpix, dpiy: Integer);
const
  BufferSize = 50;
  DPI = 1; {inch}
  DPC = 2; {cm}
var
  Buffer: string;
  index: Integer;
  FileStream: TFileStream;
  xResolution: WORD;
  yResolution: WORD;
type
  : Byte;
begin
  FileStream := TFileStream.Create(filename, fmOpenReadWrite);
  try
    SetLength(Buffer, BufferSize);
    FileStream.Read(buffer[1], BufferSize);
    index := Pos('JFIF' + #$00, buffer);
    if index > 0 then
    begin
      FileStream.Seek(index + 6, soFromBeginning);
    type
      := DPI;
      FileStream.write(type, 1);
      xresolution := swap(dpix);
      FileStream.write(xresolution, 2);
      yresolution := swap(dpiy);
      FileStream.write(yresolution, 2);
    end
  finally
    FileStream.Free;
  end;
end;

How to create a DrawGrid with a non-scrolling background image

Problem/Question/Abstract:

Are there any sources available for a DrawGrid (or kind of) with a bitmap in the background (wallpaper under the whole grid that isn't scrolled) ? I know i can draw the bitmap in the OnDrawCell event. But if the grid is scrolled, then the whole canvas is scrolled (including the background bitmap) and only the new cells are receiving a draw-message.

Answer:

This should get you started:

TExtDrawGrid = class(TDrawGrid)
protected
  procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
public
end;

procedure TExtDrawGrid.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
begin
  Canvas.Draw(ClientRect.Left, ClientRect.Top, TheBackgroundBitMap);
end;

Setting the DefaultDrawing property to false will prevent the grid from overwriting the back ground with standard cell display. You can decide what gets drawn on top of the background for any given cell. Maybe override the paint method to clean up before the rest gets slapped on top.

Perform a Locate on a date field

Problem/Question/Abstract:

How to perform a Locate on a date field

Answer:

{ ... }
var
  dr: TDateTime;
begin
  dt := EncodeDate(2003, 01, 31);
  yourDataset.Locate('yourDTFieldName', dt, [])
end;

Get the date a file was created

Problem/Question/Abstract:

How to get the date a file was created

Answer:

Solve 1:

uses
  Windows, Systutils;

function GetFileCreateDate(TheFile: string): TDateTime;
var
  SearchRec: TSearchRec;
  DT: TFileTime;
  ST: TSystemTime;
begin
  Result := 0;
  try
    if (FindFirst(TheFile, faAnyFile, SearchRec) = 0) then
    begin
      FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime, DT);
      FileTimeToSystemTime(DT, ST);
      Result := EncodeDate(st.wYear, st.wMonth, st.wDay) +
        EncodeTime(st.wHour, st.wMinute, st.wSecond, 0);
    end;
  finally
    FindClose(SearchRec);
  end;
end;


Solve 2:

{This function returns the file creation timestamp of the specified file.
Uses-clause order dependency: if "Windows" is used, it must come before "SysUtils".}

function GetFileCreationTimestamp(const FileName: string): TDateTime;
var
  SearchRec: TSearchRec;
begin
  if (FindFirst(Filename, faAnyfile, SearchRec) = 0) then
  begin
    FindClose(SearchRec);
    if ((SearchRec.FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then
      Result := UTCFileTimeToLocalTimestamp(SearchRec.FindData.ftCreationTime)
    else
      raise Exception.Create('GetFileCreationTimestamp: File is a directory.');
  end
  else
    raise Exception.Create('GetFileCreationTimestamp: File does not exist.');
end;

{This function converts a TFileTime in UTC to a TDateTime for the local time zone.}

function UTCFileTimeToLocalTimestamp(const UTCFileTime: TFileTime): TDateTime;
var
  LocalFileTime: TFileTime;
  FATDateTime: LongInt;
begin
  if (FileTimeToLocalFileTime(UTCFileTime, LocalFileTime)) then
    if (FileTimeToDosDateTime(LocalFileTime, LongRec(FATDateTime).Hi,
      LongRec(FATDateTime).Lo)) then
      Result := FileDateToDateTime(FATDateTime)
    else
      raise
        Exception.Create('UTCFileTimeToLocalTimestamp: Timestamp conversion error.')
  else
    raise Exception.Create('UTCFileTimeToLocalTimestamp: Timestamp conversion error.')
end;


Solve 3:

function FileTimeToLocalDateTime(filetime: TFileTime): TDatetime;
var
  LocalFileTime: TFileTime;
  dostime: Longint;
begin
  FileTimeToLocalFileTime(filetime, LocalFileTime);
  if FileTimeToDosDateTime(LocalFileTime, LongRec(dostime).Hi, LongRec(dostime).Lo)
    then
    Result := FiledateToDatetime(dostime)
  else
    Result := 0.0;
end;

procedure GetFileTimes(filename: string; var creationtime, lastaccesstime,
  lastwritetime: TDateTime);
var
  srec: TSearchRec;
begin
  if FindFirst(filename, faAnyfile, Srec) = 0 then
  try
    with SRec.FindData do
    begin
      creationtime := FileTimeToLocalDateTime(ftCreationTime);
      lastaccesstime := FileTimeToLocalDateTime(ftLastAccessTime);
      lastwritetime := FileTimeToLocalDateTime(ftLastWriteTime);
    end;
  finally
    FindClose(SRec);
  end
  else
    raise Exception.Create('File %s not found!', [filename]);
end;

You get from a TDatetime to string via Format, FormatDatetime, DateTimeToStr etc..

How to disable accelerators without ALT

Problem/Question/Abstract:

I have a tab control with a tab called "Polic&y Info" with the ALT-Y key set to switch to it. If I am on a TCheckBox on any tab and press only the "Y" key, the tab control switches pages.

Answer:

This is nothing specific to a checkbox, it is standard Windows behaviour. If the control having focus does not process character input then ALT is not needed to have a character act as an accelerator. To fix this, add a handler for CM_DIALOGCHAR to your form:

private
{ Private declarations }

procedure cmDialogChar(var msg: TCMDialogChar); message CM_DIALOGCHAR;

procedure TForm1.cmDialogChar(var msg: TCMDialogChar);
begin
  if ((msg.keydata and $20000000) = 0) then
    msg.result := 1 { ALT not down, eat key }
  else
    inherited;
end;

Advanced Debug manager (Exception handler)

Problem/Question/Abstract:

How to implement a Debug class that show unit name, function name and line number of an exception.

Answer:

Download the attached file...

The requirement is to enable detailled map file generation in project linker option tab.

DEBUG_MODE is a boolean constant that indiquates if Debug object is activate by default at startup.
Command line /debug and /nodebug parameters modify it.

TObjectInfos is used for getting class instance informations like name, parent(s), owner(s)...
TMapFile is used for getting an exception informations : unit name, procedure name and line number.

IDebug is an interface implemented by TDebug.
Function GetDebug return a IDebug pointer refering to a TDebug instance created and destroyed in finalization unit part.
User can't create or destroy

User can set Before and After exception event callbacks and set the activation state.
ShowException is used by the internal exception handler and can be used by user.

A beautiful except form and a log file can be implemented...


Component Download: http://download.urimont.com/DebugManager.zip

How to set tab stops in a TMemo

Problem/Question/Abstract:

How to set tab stops in a TMemo

Answer:

Solve 1:

To change the tab stops for a multiline edit control (i.e. a TMemo), send the EM_SetTabStops message to the component. The Tabs array indicates where the tab stops will be located. Since the WParam parameter to SendMessage is 1, then all tab stops will be set to the value passed in the Tabs array. Remember to set the WantTabs property of TMemo to True to enable the tabs.

procedure TForm1.FormCreate(Sender: TObject);
const
  TabInc: LongInt = 10;
begin
  SendMessage(Memo1.Handle, EM_SetTabStops, 1, Longint(@TabInc));
end;


Solve 2:

For a memo you use the EM_SETTABSTOPS message. Setting decimal tab stops in a memo control;

procedure TScratchMain.SpeedButton2Click(Sender: TObject);
var
  tabs: array[0..2] of Integer;
begin
  {set first tabstop at 12, second at 24, third at 44 character position, using the
  average width as base, converted to dialog units.4 dialog units make
        one average char width.}
  tabs[0] := 12 * 4;
  tabs[1] := 24 * 4;
  tabs[2] := 44 * 4;
  Memo1.Clear;
  Memo1.Lines.Add('01234567890123456789012345678901234567890123456789');
  Memo1.Lines.Add('Start'#9'One'#9'Two'#9'Three');
  Memo1.Perform(EM_SETTABSTOPS, 3, LongInt(@tabs));
  Memo1.Refresh;
end;

Note that the message expects the position in an arcane unit called "dialog unit", 4 of which should theoretically equal the average character width of the memos font. But using div 4 does not give the correct positioning, while using div 2 does. Don't ask me why, dialog units are really only sensible in dialogs (which are based on a dialog resource) and are relative to the font used for the dialog itself, not the controls on it.

Enable TWebBrowser copy/paste feature

Problem/Question/Abstract:

The copy or paste facility that is shown in the right click menu on any active TWebBrowser component does not work.

Answer:

In the Initialization section and Uninitialization section of the Unit place the OleInitialize(nil) and OleUninitialize;
Also do not forget to add ActiveX unit to uses.

How to create a TGraphicControl that displays an image from a TImageList

Problem/Question/Abstract:

How to create a TGraphicControl that displays an image from a TImageList

Answer:

Below is a TImage like component, which draws pictures from the imagelist. It works fine for me in D5:

unit ImageFL;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ImgList;

type
  TLFImage = class;
  TLFCustomImage = class;
  TLFAlignmentTypeH = (lh_LeftJustify, lh_Center, lh_RightJustify);
  TLFAlignmentTypeV = (lv_BottomJustify, lv_Center, lv_TopJustify);

  TLFCustomImage = class(TGraphicControl)
  private
    FImageList: TImageList;
    FBufBitMap: TBitMap;
    FImageIndex: TImageIndex;
    FDrawing: boolean;
    FCenter: boolean;
    FXStart, FYStart: integer;
    FTransparent: boolean;
    FAlignmentH: TLFAlignmentTypeH;
    FAlignmentV: TLFAlignmentTypeV;
    procedure ReCountXYValues;
    procedure PaintOneImage(AImage: integer);
    procedure SetAlignmentH(AValue: TLFAlignmentTypeH);
    procedure SetAlignmentV(AValue: TLFAlignmentTypeV);
    procedure SetImageList(Value: TImageList);
    procedure SetImageIndex(Value: TImageIndex);
    procedure SetCenter(Value: boolean);
    procedure SetTransparent(Value: boolean);
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure Paint; override;
  protected
    property AlignmentH: TLFAlignmentTypeH read FAlignmentH write SetAlignmentH;
    property AlignmentV: TLFAlignmentTypeV read FAlignmentV write SetAlignmentV;
    property ImageList: TImageList read FImageList write SetImageList;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
    property Center: boolean read FCenter write SetCenter;
    property Transparent: boolean read FTransparent write SetTransparent;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TLFImage = class(TLFCustomImage)
  published
    property Align;
    property AlignmentH;
    property AlignmentV;
    property Anchors;
    property AutoSize;
    property Constraints;
    property Color;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Hint;
    property ImageIndex;
    property ImageList;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Transparent;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('My Components', [TLFImage]);
end;

constructor TLFCustomImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  FImageList := nil;
  FXStart := 0;
  FYStart := 0;
  Height := 105;
  Width := 105;
  FAlignmentH := lh_LeftJustify;
  FAlignmentV := lv_TopJustify;
  FBufBitMap := TBitMap.Create;
  FBufBitMap.Height := Height;
  FBufBitMap.Width := Width;
  FBufBitMap.Canvas.Brush.Color := Color;
  FBufBitMap.Transparent := FTransparent;
end;

destructor TLFCustomImage.Destroy;
begin
  FBufBitMap.Free;
  inherited Destroy;
end;

procedure TLFCustomImage.Paint;
var
  Save: Boolean;
begin
  if csDesigning in ComponentState then
  begin
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
  end;
  ReCountXYValues;
  Save := FDrawing;
  FDrawing := True;
  try
    PaintOneImage(ImageIndex);
  finally
    FDrawing := Save;
  end;
end;

procedure TLFCustomImage.PaintOneImage(AImage: integer);
begin
  if not Assigned(ImageList) then
    exit;
  FBufBitMap.Height := Height;
  FBufBitMap.Width := Width;
  FBufBitMap.Canvas.Brush.Color := Color;
  FBufBitMap.Transparent := FTransparent;
  FBufBitMap.Canvas.FillRect(GetClientRect);
  FImageList.DrawOverlay(FBufBitMap.Canvas, FXStart, FYStart, AImage, 0);
  Canvas.Draw(0, 0, FBufBitMap);
end;

function TLFCustomImage.CanAutoSize(var NewWidth, NewHeight: Integer):
  Boolean;
begin
  Result := True;
  if not Assigned(ImageList) then
    exit;
  if not (csDesigning in ComponentState) or (ImageList.Width > 0)
    and (ImageList.Height > 0) then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := ImageList.Width;
    if Align in [alNone, alTop, alBottom] then
      NewHeight := ImageList.Height;
  end;
end;

procedure TLFCustomImage.ReCountXYValues;
begin
  FYStart := 0;
  FXStart := 0;
  if not Assigned(ImageList) then
    exit;
  case FAlignmentV of
    lv_BottomJustify:
      FYStart := Height - ImageList.Height;
    lv_Center:
      FYStart := (Height - ImageList.Height) div 2;
    lv_TopJustify:
      FYStart := 0;
  end;
  case FAlignmentH of
    lh_LeftJustify:
      FXStart := 0;
    lh_Center:
      FXStart := (Width - ImageList.Width) div 2;
    lh_RightJustify:
      FXStart := Width - ImageList.Width;
  end;
end;

procedure TLFCustomImage.SetAlignmentH(AValue: TLFAlignmentTypeH);
begin
  if FAlignmentH <> AValue then
  begin
    FAlignmentH := AValue;
    Invalidate;
  end;
end;

procedure TLFCustomImage.SetAlignmentV(AValue: TLFAlignmentTypeV);
begin
  if FAlignmentV <> AValue then
  begin
    FAlignmentV := AValue;
    Invalidate;
  end;
end;

procedure TLFCustomImage.SetImageList(Value: TImageList);
begin
  FImageList := Value;
  Invalidate;
end;

procedure TLFCustomImage.SetImageIndex(Value: TImageIndex);
begin
  if FImageIndex <> Value then
  begin
    FImageIndex := Value;
    Invalidate;
  end;
end;

procedure TLFCustomImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;

procedure TLFCustomImage.SetTransparent(Value: boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;

end.

How to set the default printer in Windows

Problem/Question/Abstract:

Does anyone know how to set a particular printer as the default printer programmatically in Windows (both 98 and NT) in Delphi?

Answer:

Change default printer:

{ ... }
var
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.PrinterIndex := ....; {select printer to make default}
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  StrCat(Device, ',');
  StrCat(Device, Driver);
  StrCat(Device, ',');
  StrCat(Device, Port);
  WriteProfileString('windows', 'device', Device);
  StrCopy(Device, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, longint(@Device));
end;

Gaussian Blur in Delphi

Problem/Question/Abstract:

Gaussian Blur in Delphi

Answer:

The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much.

The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.)

One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution.

Anyway, you can do this:


unit GBlur2;

interface

uses
  Windows, Graphics;

type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed record
    b: byte; {easier to type than rgbtBlue}
    g: byte;
    r: byte;
  end;
  PRow = ^TRow;
  TRow = array[0..1000000] of TRGBTriple;
  PPRows = ^TPRows;
  TPRows = array[0..1000000] of PRow;

const
  MaxKernelSize = 100;

type
  TKernelSize = 1..MaxKernelSize;
  TKernel = record
    Size: TKernelSize;
    Weights: array[-MaxKernelSize..MaxKernelSize] of single;
  end;
  {the idea is that when using a TKernel you ignore the Weights except
  for Weights in the range -Size..Size.}

procedure GBlur(theBitmap: TBitmap; radius: double);

implementation

uses
  SysUtils;

procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the current application
you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so
that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small
Size is good because the execution time is going to be propertional to K.Size.)}
var
  j: integer;
  temp, delta: double;
  KernelSize: TKernelSize;
begin
  for j := Low(K.Weights) to High(K.Weights) do
  begin
    temp := j / radius;
    K.Weights[j] := exp(-temp * temp / 2);
  end;
  {now divide by constant so sum(Weights) = 1:}
  temp := 0;
  for j := Low(K.Weights) to High(K.Weights) do
    temp := temp + K.Weights[j];
  for j := Low(K.Weights) to High(K.Weights) do
    K.Weights[j] := K.Weights[j] / temp;
  {now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter.
  This is important, otherwise a blur with a small radius will take as long as with a large radius...}
  KernelSize := MaxKernelSize;
  delta := DataGranularity / (2 * MaxData);
  temp := 0;
  while (temp < delta) and (KernelSize > 1) do
  begin
    temp := temp + 2 * K.Weights[KernelSize];
    dec(KernelSize);
  end;
  K.Size := KernelSize;
  {now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1}
  temp := 0;
  for j := -K.Size to K.Size do
    temp := temp + K.Weights[j];
  for j := -K.Size to K.Size do
    K.Weights[j] := K.Weights[j] / temp;
end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
  if (theInteger <= Upper) and (theInteger >= Lower) then
    result := theInteger
  else if theInteger > Upper then
    result := Upper
  else
    result := Lower;
end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin
  if (x < upper) and (x >= lower) then
    result := trunc(x)
  else if x > Upper then
    result := Upper
  else
    result := Lower;
end;

procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
  j, n, LocalRow: integer;
  tr, tg, tb: double; {tempRed, etc}
  w: double;
begin
  for j := 0 to High(theRow) do
  begin
    tb := 0;
    tg := 0;
    tr := 0;
    for n := -K.Size to K.Size do
    begin
      w := K.Weights[n];
      {the TrimInt keeps us from running off the edge of the row...}
      with theRow[TrimInt(0, High(theRow), j - n)] do
      begin
        tb := tb + w * b;
        tg := tg + w * g;
        tr := tr + w * r;
      end;
    end;
    with P[j] do
    begin
      b := TrimReal(0, 255, tb);
      g := TrimReal(0, 255, tg);
      r := TrimReal(0, 255, tr);
    end;
  end;
  Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;

procedure GBlur(theBitmap: TBitmap; radius: double);
var
  Row, Col: integer;
  theRows: PPRows;
  K: TKernel;
  ACol: PRow;
  P: PRow;
begin
  if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
    raise exception.Create('GBlur only works for 24-bit bitmaps');
  MakeGaussianKernel(K, radius, 255, 1);
  GetMem(theRows, theBitmap.Height * SizeOf(PRow));
  GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
  {record the location of the bitmap data:}
  for Row := 0 to theBitmap.Height - 1 do
    theRows[Row] := theBitmap.Scanline[Row];
  {blur each row:}
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do
    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
  {now blur each column}
  ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
  for Col := 0 to theBitmap.Width - 1 do
  begin
    {first read the column into a TRow:}
    for Row := 0 to theBitmap.Height - 1 do
      ACol[Row] := theRows[Row][Col];
    BlurRow(Slice(ACol^, theBitmap.Height), K, P);
    {now put that row, um, column back into the data:}
    for Row := 0 to theBitmap.Height - 1 do
      theRows[Row][Col] := ACol[Row];
  end;
  FreeMem(theRows);
  FreeMem(ACol);
  ReAllocMem(P, 0);
end;

end.



Example:


procedure TForm1.Button1Click(Sender: TObject);
var
  b: TBitmap;
begin
  if not openDialog1.Execute then
    exit;
  b := TBitmap.Create;
  b.LoadFromFile(OpenDialog1.Filename);
  b.PixelFormat := pf24Bit;
  Canvas.Draw(0, 0, b);
  GBlur(b, StrToFloat(Edit1.text));
  Canvas.Draw(b.Width, 0, b);
  b.Free;
end;


Note that displaying 24-bit bitmaps on a 256-color system requires some special tricks - if this looks funny at 256 colors it doesn't prove the blur is wrong.

Access the recent documents

Problem/Question/Abstract:

How can I add a document that my application processed to the folder of recent documents?

Answer:

Use the procedure SHAddToRecentDocs as shown in the code below.

// use these pascal procedures or call SHAddToRecentDocs directly

procedure Win95AddToRecentDocs(const Filename: string);
begin
  SHAddToRecentDocs(SHARD_PATH, @Filename[1]);
end;

procedure Win95ClearRecentDocs;
begin
  SHAddToRecentDocs(SHARD_PATH, nil);
end;

How to change the printer resolution

Problem/Question/Abstract:

I'm trying to change the print resolution of TPrinter from my application. But it works only if I change this parameter in a TPrintDialog. Commands like "Printer.Canvas.Font.PixelsPerInch := NewResolution" don't work.

Answer:

The first step is to find out which resolutions the printer supports. You do that via Winspool.Devicecapabilities. You select one of the available settings and the modify two fields of the printers devmode structure accordingly.

Create a new project, drop a TRadiogroup and a TButton on it, leave the radiogroup empty. Add handlers for the forms OnCreate event and the buttons OnClick.

uses
  winspool, Printers;

{$R *.DFM}

type
  TPrinterResolution = record
    resx, resY: Longint;
  end;
  TPrinterResolutions = array of TPrinterResolution;

function GetPrinterResolutions: TPrinterResolutions;
var
  numResolutions: Integer;
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numResolutions := WinSpool.DeviceCapabilities(Device, Port, DC_ENUMRESOLUTIONS, nil,
    nil);
  SetLength(Result, numResolutions);
  if numResolutions > 0 then
  begin
    WinSpool.DeviceCapabilities(Device, Port, DC_ENUMRESOLUTIONS, @Result[0], nil);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  resarray: TPrinterResolutions;
  i: Integer;
begin
  resArray := GetPrinterResolutions;
  for i := 0 to Length(resarray) - 1 do
  begin
    {create a radiobutton for each resolution, pack the actual resolution into
                        its Tag property}
    radiogroup1.Items.add(format('%d x %d dpi', [resarray[i].resX,
      resarray[i].resY]));
    radiogroup1.Controls[i].Tag := MakeLong(LoWord(resarray[i].resX),
      LoWord(resarray[i].resY));
  end;
  if radiogroup1.items.count > 0 then
  begin
    radiogroup1.itemindex := 0;
    radiogroup1.clientheight := radiogroup1.ControlCount *
      radiogroup1.controls[0].height;
  end
  else
    button1.enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  pDevMode: PDeviceMode;
  dw: DWORD;
begin
  with radiogroup1 do
    dw := Controls[itemindex].Tag;
  {test print using selected resolution}
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  {force reset of devmode}
  Printer.SetPrinter(Device, Driver, Port, 0);
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  if hDevmode <> 0 then
  begin
    pDevmode := GlobalLock(hDevmode);
    if pDevmode <> nil then
    try
      pDevMode^.dmPrintQuality := LoWord(dw);
      pDevmode^.dmYResolution := HiWord(dw);
      pDevmode^.dmFields := pDevmode^.dmFields or DM_PRINTQUALITY or DM_YRESOLUTION;
    finally
      GlobalUnlock(hDevmode);
    end;
    Printer.beginDoc;
    try
      with Printer.Canvas.Font do
      begin
        Name := 'Arial';
        Size := 24;
      end;
      {print test string 1 inch from margins}
      Printer.Canvas.textOut(LoWord(dw), HiWord(dw), 'This is a test');
    finally
      Printer.endDoc;
    end;
  end;
end;

How to move the active record in a table to a certain position on a TDBGrid (2)

Problem/Question/Abstract:

Does anyone have a suggestion as to how I can force a DBGrid to always have the "current" record in the top row of the grid? I am navigating the table with the use of a Navigator tool and would like to display the next several records in the table in the grid.

Answer:

I think I found a usable, if not particularly elegant solution: Use a cracker class to locate one's position within the grid, and use that to jump forward and back through the dataset to position the current record at the top.

My test case works only from the Navigator. Moving in either direction with the Navigator will reposition the current record to the top of the grid, if there are enough records after the current one to allow it.

If you want to set up a test case: Drop a Navigator and Grid on a new project, with all other requisite components (table, query, datasource, etc.), and replace the unit's code with the following. Hook up the Navigator's OnClick to the appropriate routine.


unit Unit1;

{$O-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, DBCtrls, Db, DBTables, Grids, DBGrids, StdCtrls;

type
  TForm1 = class(TForm)
    DBGrid1: TDBGrid;
    DataSource1: TDataSource;
    Table1: TTable;
    DBNavigator1: TDBNavigator;
    procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
  private
  public
  end;

  TGridCracker = class(TDBGrid);

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var
  RowsActuallyMoved: Integer;
begin
  with TGridCracker(DBGrid1) do
  begin
    BeginUpdate; {seems ineffectual, like other draw-locking mechanisms, but...}
    if Row <> TopRow then
    begin
      RowsActuallyMoved := Table1.MoveBy(RowCount);
      Table1.MoveBy(-RowsActuallyMoved); {take care of boundary cases; ie. EOF}
    end;
    EndUpdate;
  end;
end;

end.

How to do date math on calculated fields

Problem/Question/Abstract:

How to do date math on calculated fields

Answer:

When doing date math on calculated fields, it is important to ensure that all values being used are properly matched as to type. The double method (not in the docs) casts the value to a useable type. In the following method, d1 and d2 (part of table1) can be of either date or dateTime type and d3 is an integer field.

procedure TForm1.Table1CalcFields(DataSet: TDataset);
var
  t1, t2: TDateTime;
begin
  table1d1.asDateTime := Date + 2; {or table1d1.value := date + 2;}
  table1d2.asDateTime := Date - 2;
  t1 := table1d1.asDateTime;
  t2 := table1d2.asDateTime;
  table1d3.asInteger := trunc(double(t1) - double(t2));
end;

Display hierarchical drive information in a TTreeView

Problem/Question/Abstract:

How can I insert a hierarchy drive in a TTreeView? I would liket to insert for example my drive C:\ in the treeview.

Answer:

procedure FilePathToTreeNode(aTreeView: TTreeView; aRoot: TTreeNode;
  Path: string; Recurse: boolean);
var
  NewNode: TTreeNode;
  SRec: TSearchRec;
begin
  if FindFirst(Path + '*.*', SysUtils.faAnyFile, SRec) = 0 then
    repeat
      if (sRec.Name = '.') or (sRec.Name = '..') then
        Continue;
      NewNode := aTreeView.Items.AddChild(aRoot, SRec.Name);
      if Recurse and ((srec.Attr and sysutils.faDirectory) <> 0) then
        FilePathToTreeNode(aTreeView, NewNode, Path + srec.name + '\', True);
    until
      FindNext(SRec) <> 0;
end;

Call it like this:

FilePathToTreeNode(TreeView1, nil, 'c:\', True);

Consider using ShellTreeView and ShellListView from the samples component page (at least in D6).

Delphi ActiveX/Midas Development Hints

Problem/Question/Abstract:

Delphi ActiveX/Midas Development Hints

Answer:

Introduction

This document provides a basis for developing multi-tier database applications that have zero client configuration administration. This architecture was a requirement of the National Department of Agriculture brought on by a shortage of support personnel and the wide spread dispersion of the user-base throughout South Africa. Delphi was chosen as the development platform because it implemented the technologies required, and has a proven track record.

The requirement made was to have a user with limited computer experience download the program automatically and run it, without manually installing anything on his side. Also if a newer version of the program was released, it should automatically update the application on the client. The technology chosen for accomplishing this was to run an ActiveX application within a browser using Microsoft's DCOM technologies to access the data. Also Delphi's Midas technologies have features that make it easy to work with DCOM through a firewall and over the Internet. There is also support for MTS.

The first Server DCOM Application

Preparing the Server: The first thing to do before you can write a DCOM Server Application is to set up the server first, this is the only machine where you need to set up the connection to the database. This can be the Web-Server machine, but doesn't have to be. First set up the ODBC driver (system) to the appropriate Server and Database, then test the connection. Then you must install Delphi's BDE (preferably their latest one), or with Delphi 5, you can chose to use ADO instead, in this case you don't have to install the BDE on the NT machine (ADO drivers come with NT). After installing make sure you have DBCLIENT.DLL and STDVCLxx.DLL in the System32 directory (for Delphi 4 use STDVCL40.DLL), if not, copy them from your Delphi Development machine to the NT Server. Also copy the scktcrvr.exe file over to a directory on the server and put it in the Server startup group (this is part of Midas, and will be explained later).
Writing the Server Application: On your development machine, install the odbc driver exactly the same way you installed it on the Server, with the same name. In Delphi, open a new Project, a blank form will appear, you do not need this form, but it is good practice to put a label on it describing the role of the Server app. Add a new module to your project, chose the Remote Data Module form from the multitier group, give it a name and leave the defaults, this is where you place all your data-access tables that will be provided remotely to the client. Add the Database component from the Data Access tab to the new form, set the following properties:

DatabaseName:        odbc_name_that_you_defined
LoginPrompt:                false
Params:                                USER NAME=username_of_odbc_database_server
                                                        PASSWORD=password_of_username
Connected:                        true

If the connected property does not want to set to true, then there is a connection problem, make sure everything is set up correctly and that your odbc driver on the development machine is working, then try again. After this works, you can drop the Query (or Table) component onto the new form, set the following properties:

CachedUpdates:        false (this is true for editable tables, but our first server will be read-only)
DatabaseName:        odbc_name_that_you_defined
SQL:                                        Select * from your_table_in_the_database
Active:                                false (NB this is compulsory)

You can test your connection by setting the Active property to true, but under no circumstances deploy this application with the Active property set to true, doing so will disable remote refreshing of the table, rather let your client control this property. When you have completed the above, you can right-click on the Query (or Table) component, one of the Items appearing in the pop-up menu is called 'Export Query1 from Data Module', select this. You will notice that after this operation the item does not appear again in the pop-up menu. Now save your project and compile it. Your server application is now finished. To deploy this Server Application to the Server just copy it across to a directory on the server, then on the Server console run it once, this will automatically register it in the registry (make sure the scktsrvr.exe program is also running, if not, run it). Now your DCOM Server is ready to process any requests.

If you need need to replace the Server App with a modified version, do not copy the new one over the old one, first unregister the old one by going to the dos-prompt to the Server directory and typing: Your_Server_App_Name /unregserver. When this executes silently, you can copy the new one over the old one and manually execute it to register it.

The first ActiveX Client Application

Open a New ActiveForm application under the ActiveX tab of the 'New&#8230;' menu item and provide a name (leave the rest default), if you had a previous project open it will display a warning message that the ActiveForm cannot be added to the current project and needs to close the project, click to accept this. Add somewhere on the form a SocketConnection component from the 'Midas' tab, set the following properties in the order provided:

Address:                        Physical_IP_address_of_Server (e.g. 155.240.96.100)
ServerName:        Select_your_server_from_list
Connected:                true

If your program should be deployed outside the NT Domain area (i.e. the Internet or WAN) then it is better to use the Address property than the Host property, that is because the Host can only be resolved locally. If you do not see your Server Application in the drop-down list under ServerName, then there is a problem with either the Server Setup (See above), or the IP Address is wrong (Make sure that both the scktsrvr.exe and your server app is running, if so then you might not have exported the Query component from the Data Module via the pop-up menu). If all works fine you can add a ClientDataset component (also from the 'Midas' tab) to the form and set the following properties in the order provided:

RemoteServer:        Select_Your_SocketConnection_from_list
ProviderName:        Select_Your_Query_component_from_list
Active:                                true

If the above works, which should, you now have a local record set of a remote table, all that you must now do is use it. Add a DataSource component (under the 'Data Access' tab) to the form and select your ClientDataSet component in the DataSet property. Add a DBGrid component to the form (under 'Data Controls') and select the DataSource component in the DataSource property. If you have followed all the steps correctly, you should now see data in the Grid, enlarge it to have a larger view. The simple ActiveX application is now finished, save your work and compile it. To test your form in a browser you must deploy it, to do this you must set a few options in the 'Web Deployment Options&#8230;' first. We will deploy your app to a directory on your hard drive as this will speed up the deployment and page-open time. Set the Target directory field and the HTML directory field to the same value being the drive and directory you want to store the htm and ocx file. In the Target URL just enter './', this makes it possible to execute the htm file directly from the directory (this would otherwise point to the URL of where the ocx file would be found). Now you can deploy your app with the 'Web Deploy' menu option, if everything was set up correctly, you should have an htm file and an ocx file in the directory you specified. Browse to that directory with your Windows explorer, and double-click on the htm file&#8230; your Internet Browser should open, and after a delay, you should see your program running within.

If you want to deploy to a Web server, it is important that you have 'Deploy additional files' clicked in the Web Deployment Options. After this, go to the 'Additional Files' tab and add the dbclient.dll file found in your /winnt/system32 directory. Not always, but sometimes if the application still gives an error when run, add the stdvcl40.dll file also found in the same directory. You should see an INF file created in your deployment directory when you deploy, including the dll files.

If you click CAB file compression in the Deployment Options, try to compress each file added separately (options available in the 'Additional Files' tab. This will ensure that no unnecessary downloads take place when one of the components (ocx or dll) is updated.

Persistent verses Dynamic Fields

In the above example, you used dynamic field allocation, you did not have to tell the DBGrid component what fields are available in the table, it deduced that from itself by examining the field results from the Select * statement. The nice thing with this is that if your table structure changed in the table you used, you would not have to modify the program, the new structure will be available dynamically in the DBGrid. You can even edit using the DBGrid. Even when you use separate edit fields (DBEdit, DBMemo, DBImage, etc), you can get the field names from a dynamic field list. There are two situation where you might consider using persistent fields (field names that you define during design time), the first is if you want to manipulate field values programmatically, the second would be when you want to use field values as parameters in your own SQL statements. To make fields persistent, you just right-click on the Table or Query component and select 'Fields editor&#8230;' from the drop-down menu. In the Field Editor you just add the fields you need, a separate field type is created for each field that can be referenced in code. (e.g. a field called name in the Query1 component can be referenced as Query1name.value).

You will notice in the fields editor that you can add new fields (user defined) that you can assign yourself or automatically (e.g. Lookup fields, Calculated fields etc). For lookup fields you just define the lookup field and key values in a foreign table, with a calculated field you use the OnCalculateFields event to add code to calculate the field value for each record.

You will also notice in the persistent field properties in the field editor that each field has a list of it's own properties, one of them is called 'Displayed Name', this property is used to enter a formatted description that appears in the header part of the DBGrid, change this if you want to see a field description instead of the field name on the field headers.

You can separately configure what fields to display in a DBGrid by right-clicking on the DBGrid component and selecting the fields to display in it's own field editor.

Using filters on a Table or Query

In certain cases you may want to shrink the size of the result query for search purposes by using certain search criteria. One way to do this is to modify the SQL in such a way as to return only a smaller sub-set of the query using a where clause. This is however inefficient as the query requires the SQL to be executed on the server, the new dataset returned to the client, and when the client is finished with the dataset and needs to be returned to it's previous state, the old SQL has to be executed and the result returned. This, even with a thin client takes time and wastes bandwidth. Delphi provides a means to filter the current dataset without re-issuing any SQL, each dataset (Query or Table) has a filter and filtered property to enable this. In the filter property you can add a string such as 'surname='Smith'' (you can set this programmatically), the filter won't engage until you set the filtered property to true. Setting the filtered property to false disables the filter again and restores your viewed recordset. The nice thing about this is that all processing gets done on the workstation, and happens instantly, as opposed to re-issuing an SQL command.

Opening a dialog form from an ActiveForm

The one thing you might want your program to have is a load of custom dialogs, however, if you add a standard form to your ActiveForm application, you'll notice that the form opens within the region of your ActiveForm app. You would ideally like to open a form external to your ActiveForm app/browser. You can do this by instantiating the form within the unit of the form instead of instantiating (Showmodal) it from within the unit of the ActiveForm. To do this follow these steps:

Add a new form to the project, make sure the prj file does not instantiate the form, if so, remove the reference.
Remove the variable of the form type.
In the unit of the form add a function called ShowForm, with a return result of TmodalResult. Add var parameters you'd like returned. An example of the implementation code should look like the following:

function ShowForm: TmodalResult;
var
  AXForm: TAXForm; // the variable of the form here
begin
  AXForm := TAXForm.Create(Application);
  ShowForm := AXForm.ShowModal;
  AXForm.Free;
end;

Now add this unit to the uses clause of the ActiveForm. To call the form, just call the ShowForm function of the dialog. (you can even have menus on these forms).

On the dialog box you normally add an OK and CANCEL button to close the form, however, you would normally like to know which of the buttons were pressed, this is where ModalResult comes in. When you add a button to the dialog, you'll notice that among the button's properties is a modalresult property, selecting the button type from the drop-down list changes the function of the button. The ShowModal result returns the value you selected as the modalresult of the button (e.g. mrOK or mrCancel), and closes the form automatically without you having to enter code to close the form. You can then react on the result returned.

Handling database errors

Sometimes when you update a table and the update is unsuccessful, you'd like to know exactly what the error was instead of trying to figure out what went wrong. One of the most common type of errors that occur is when someone modifies a record that you are currently modifying, this is an example of a typical reconcile error. Fortunately Delphi makes it simple to capture the exact error and display it with the standard ReconcileError dialog form. Just add the form to the project, make sure the prj file does not instantiate the form, if so, remove the reference. Add the unit name of the dialog to the uses clause of all the forms that have clientdatasets you want monitored. Double-click the OnReconcileError property of the Table/Query you want monitored and type the following code in the handler: Action := HandleReconcileError(DataSet, UpdateKind, E);
Now when you receive an error, the dialog will pop-up with the appropriate error, and also give a list of the fields involved and their data. The dialog also allows you to take certain actions (e.g. skip, Cancel, etc ).

Updating data

When working with data on a local Query component, you can add an UpdateSQL component to the form and connect it to the UpdateObject property of the Query component. However, if working with a Query component in a DCOM remote data module, this step is not necessary, as the appropriate SQL is automatically generated for delete, insert and modify. If however you do need to use parameters, you can use the Provider.BeforeUpdateRecord event to execute your SQL (The UpdateSQL component is not supported here). Code within this event will look something like:

if UpdateKind = ukDelete then
begin
  Query1.SQL.Text := 'Update CUSTOMER set STATUS="DEL" where ID=:ID';
  Query1.Params[0].Value := SourceDS.FieldByName('ID').Value;
  Query1.ExecuteSQL;
  Applied := true;
  // restore the SQL here
end;

If you have a Join select statement in a Query, the Query component needs to know which one of the tables used in the statement need to be updated, and what fields are involved in the update to that table, otherwise you get an 'Unable to resolve record, Table name not found' error. Using a separate Provider component, do the following:
In the Provider.OnGetDatasetProperties event, add the code:

Properties := VarArrayCreate([0, 0], varVariant);
Properties[0] := VarArrayOf(['TABLE_NAME', table_name_you_want_updated, true]);

Add persistent fields to the remote data module for the join query.
Select the non-involved TFields in the fields-editor and set all of the ProviderFlags elements to false. (i.e. set pfInUpdate and pfInWhere to false).

Now the Query component will be able to correctly build up the update SQL statements.

If you use a separate form to modify data and you need to refresh the root-view so as to reflect any changes made, use the Query.refresh method of the root-view form. Also remember that if you have CachedUpdates set to true, you must apply those updates with the Query.ApplyUpdates(-1) method.

Dynamically identify checkboxes

Problem/Question/Abstract:

My code looks something like this: ... if CheckBox(var).checked = True then ... where (var) is a counter in a for loop. Is the number of checkboxes not known when coding , ie created only at run time?

Answer:

When in design mode, you really should know how many checkboxes are on a given form. When the App is running, use Delphi's Run Time Type Information (RTTI). For a given form, try the following code snippet:

var
  i: Integer
begin
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TCheckBox then
      (Components[i] as TCheckBox).Checked then
    begin
      {... insert your code here ...}
    end;
end;

In addition, the following code is a valid statement in Delphi:

if Components[i] = CheckBox5 then  DoSomething;

Also, each component in Delphi has a Published Property called 'Tag', you can use this to your advantage by setting the Tag to some non-zero number at design time, then using it at runtime, ie:

var
  i: Integer
begin
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TCheckBox then
      with (Components[i] as TCheckBox) do
        case Tag of
          1: if Checked then
              DoSomethingOnBox1;
          2: if Checked then
              DoSomethingOnBox2;
          {... etc ...}
        end;
end;

A Class to Print Labels

Problem/Question/Abstract:

A very simple class to print labels

Answer:

A very simple class to print labels.

What do we need to print labels ?

The size (height and width) of every label.
The number of labels per row.
The top and left margin.
The kind of measure: pixels or inches.
The font to use.
And of course data to fill the labels.

With the next class we can do it very simply, Im going to use a pseudo-code to explain the use of the class TAlLabels:

var
  xLabels: TAlLabels;

begin
  xLabels := TAlLabels.Create;
  xLabels.Inches := True; // im going to use inches instead of pixels
  xLabels.Font := FontDialog1.Font; // I get the font from a Font Dialog
  xLabels.LabelsPerRow := 4; // 4 Label per row
  xLabels.LabelWidthInch := 3; // only an example
  xLabels.LabelHeightInch := 1.5; // only an example
  xLabels.LeftMarginInch := 0; // only an example
  xLabels.TopMarginInch := 0; // only an example
  xLabels.Open; // open the printer
  Table.First // Im going to read a customer table
  while not Table.Eof do
  begin
    xLabels.Fill(["Name", "Street", "City"]); // I fill the content of every label
    Table.Next;
  end;
  xLabels.Close; // close the printer and print any label pending on the buffer
  xLabels.Free;
end;

We need only 3 methods: Open, Fill and Close.

The properties that we need are:

Inches: True if the measure is on Inches, False if the measure is on Pixels.

Font
LabelsPerRow
LabelWidthInch
LabelHeightInch
LeftMarginInch
TopMarginInch

if we need to specify pixels instead of Inches we are going to use the next properties.

LabelWidth
LabelHeight
LeftMargin
TopMargin
Inches := False

Thus, the same example with pixels will be

var
  xLabels: TAlLabels;

  begin
    xLabels := TAlLabels.Create;
    xLabels.Inches := False; // im going to use pixels instead of inches
    xLabels.Font := FontDialog1.Font; // I get the font from a Font Dialog
    xLabels.LabelsPerRow := 4; // 4 Label per row
    xLabels.LabelWidth := 300; // only an example
    xLabels.LabelHeight := 200; // only an example
    xLabels.LeftMargin := 0; // only an example
    xLabels.TopMargin := 0; // only an example
    xLabels.Open; // open the printer
    Table.First // Im going to read a customer table
    while not Table.Eof do
    begin
      xLabels.Fill(["Name", "Street", "City"]); // I fill the content of every label
      Table.Next;
    end;
    xLabels.Close; // close the printer and print any label pending on the buffer
    xLabels.Free;
  end;

The class:

unit ULabels;
{
Class to print labels
Author: Alejandro Castro
Date 1/Abr/2002
}

interface

uses SysUtils, Windows, Graphics, Printers;

type
  TAlLabels = class(TObject)
  private

    xWhichLabel: Integer;
    xBuffer: Boolean;
    xLabelsPerRow: Integer;
    xRowsPerLabel: Integer;

    function ReadLabxRow: Integer;
    procedure WriteLabxRow(const Value: Integer);

    function ReadRowxLab: Integer;
    procedure WriteRowxLab(const Value: Integer);

    function ReadFont: TFont;
    procedure WriteFont(const Value: TFont);

  public
    LabelWidth: Integer; // width on pixels of every label
    LabelWidthInch: Real; // width on inches of every label

    LabelHeight: Integer; //  height on pixels of every label
    LabelHeightInch: Real; // height on inches of every label

    TopMargin: Integer; // margin on pixels on top of every page
    TopMarginInch: Real; // margin on inches on top of every page

    LeftMargin: Integer; // margin on inches on top of every page
    LeftMarginInch: Real; // margin on inches on top of every page

    Inches: Boolean; // true=size on inches, false=size on pixels

    TabsStop: array of integer; // horizontal position on pixels of every label
    Content: array of array of string; // content of every label

    property Font: TFont read ReadFont write WriteFont; // font for all rows
    property LabelsPerRow: Integer read ReadLabxRow write WriteLabxRow;
    property RowsPerLabel: Integer read ReadRowxLab write WriteRowxLab;

    constructor Create;
    procedure Fill(xCont: array of string); // fill a label
    procedure PrintRow; // print a row of labels
    procedure Clean; // clean the array CONTENT of labels
    procedure Close; // close the printer and print pending labels
    procedure Open; // open the printer

  end;

implementation

constructor TAlLabels.Create;
begin
  RowsPerLabel := 1;
  LabelsPerRow := 1;

  LabelWidth := 0;
  LabelWidthInch := 0;

  LabelHeight := 0;
  LabelHeightInch := 0;

  TopMargin := 0;
  TopMarginInch := 0;

  LeftMargin := 0;
  LeftMarginInch := 0;

  Inches := True;

  xWhichLabel := 0;
  xBuffer := False;

end;

procedure TAlLabels.Open;
var
  PixPerInX, PixPerInY, i: Integer;
begin
  Printer.BeginDoc;
  PixPerInX := getDeviceCaps(Printer.Handle, LOGPIXELSX);
  PixPerInY := getDeviceCaps(Printer.Handle, LOGPIXELSY);
  if Inches then
  begin
    LabelWidth := Trunc(LabelWidthInch * PixPerInX);
    LabelHeight := Trunc(LabelHeightInch * PixPerInY);
    LeftMargin := Trunc(LeftMarginInch * PixPerInX);
    TopMargin := Trunc(TopMarginInch * PixPerInY);
  end;
  for i := 0 to LabelsPerRow - 1 do
    TabsStop[i] := LeftMargin + LabelWidth * (i);
  Clean;
end;

procedure TAlLabels.Close;
begin
  PrintRow;
  Printer.EndDoc;
end;

function TAlLabels.ReadLabxRow: Integer;
begin
  Result := xLabelsPerRow;
end;

procedure TAlLabels.WriteLabxRow(const Value: Integer);
var
  i: Integer;
begin
  xLabelsPerRow := Value;

  SetLength(TabsStop, Value);
  for i := 0 to high(Content) do
    SetLength(Content[i], Value);
  Clean;
end;

function TAlLabels.ReadRowxLab: Integer;
begin
  Result := xRowsPerLabel;
end;

procedure TAlLabels.WriteRowxLab(const Value: Integer);
begin
  SetLength(Content, Value);
  xRowsPerLabel := Value;
  LabelsPerRow := LabelsPerRow; // to call the WriteLabxRow function
  Clean;
end;

function TAlLabels.ReadFont: TFont;
begin
  Result := Printer.Canvas.Font;
end;

procedure TAlLabels.WriteFont(const Value: TFont);
begin
  Printer.Canvas.Font.Assign(Value);
end;

procedure TAlLabels.Clean;
var
  i, j: Integer;
begin
  for i := 0 to high(Content) do
    for j := 0 to high(Content[i]) do
      Content[i, j] := '';
  xBuffer := False;
  xWhichLabel := 0;
end;

procedure TAlLabels.Fill(xCont: array of string);
var
  i: Integer;
begin
  xBuffer := True;
  if High(xCont) + 1 > RowsPerLabel then
    RowsPerLabel := High(xCont) + 1;

  for i := 0 to High(xCont) do
    Content[i, xWhichLabel] := xCont[i];

  inc(xWhichLabel);
  if xWhichLabel >= LabelsPerRow then
  begin
    PrintRow();
  end;
end;

procedure TAlLabels.PrintRow;
var
  i, j, k, y, y1: Integer;
begin
  if xBuffer then
  begin
    if Printer.Canvas.PenPos.y = 0 then
      Printer.Canvas.MoveTo(0, TopMargin);

    y := Printer.Canvas.PenPos.y;
    y1 := y;

    for i := 0 to RowsPerLabel - 1 do
    begin
      for j := 0 to xWhichLabel - 1 do
      begin
        Printer.Canvas.TextOut(TabsStop[j], y, Content[i, j]);
      end;
      inc(y, Printer.Canvas.Textheight('X'));
    end;

    k := LabelHeight + y1;
    if k + LabelHeight > Printer.PageHeight then
      Printer.NewPage
    else
      Printer.Canvas.MoveTo(0, LabelHeight + y1);
  end;
  Clean;

end;

end.


Component Download: http://www.baltsoft.com/files/dkb/attachment/ULabels.zip

Encrypting an image

Problem/Question/Abstract:

How can I encrypt an image?

Answer:

procedure EncryptBMP(const BMP: TBitmap; Key: Integer);
var
BytesPorScan: Integer;
w, h: integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(BMP.ScanLine[1]) -
Integer(BMP.ScanLine[0]));
except
raise Exception.Create('Error');
end;
RandSeed := Key;
for h := 0 to BMP.Height - 1 do
begin
P := BMP.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
EncryptBMP(Image1.Picture.Bitmap, 623);
Image1.Refresh;
end;

{ Call the function again to decrypt it }
{ Zum Entschl�sseln die Funktion nochmals aufrufen }

Anti-Debugging Tips

Problem/Question/Abstract:
I found this article on the net. The author is Roy Hasson (roy@soft-analysts.com)
Anti-debugging tricks are key components in any software protection solution.  Protecting the application&#8217;s code from prying eyes can increase the security of the product a great deal.  There are many tools available to on the Internet for analyzing code at runtime and in a deadlisting.  It is difficult to protect against every single tool out there, but 99% of the time a finite set of tools will be used.  Such tools are SoftIce, a real mode debugger, IDA and W32dasm which are tools to disassemble an application.  In the following paper several anti-debugging techniques will be demonstrated.  Any code example will be giving in a x86 assembly language due to it&#8217;s easy of use in such operations

Answer:

The tricks &#8211;



Name: MeltIce



Description: Detect the presence of SoftIce and many other memory resident tools by attempting to load SoftIce related devices such its display driver, or its access driver.

Devices such as SICE, NTICE, SIWVID, FROGICE.



Example:



szSICE = &#8220;\\.\SICE&#8221; ;

hSICE = CreateFileA(szSICE, GENERIC_READ, NULL, NULL, OPEN_EXISTING\

FILE_ATTRIBUTE_READONLY, NULL);

if (hSICE !=NULL) printf (Error: softice detected);

else continue&#8230;..



Notes: This trick is old and well known, it still works well but is easily circumvented.





Name: BoundsChecker



Decription: SoftIce uses something called BoundsChecker for trapping certain exceptions, this interface can be exploited to detect the presence of SoftIce.



Example:



mov ebp,&#8221;BCHK&#8221;

mov ax,4

int 3

cmp ax,4

jne softice_detected



Notes: An older trick but still works, it is very simple to implement thus should be used just to add additional checks.





Name:  VXD ID



Description:  SoftIce could be detected by reading its VXD ID from memory.



Example:



mov ax,01684h

mov bx,0202h ; VXD ID for SoftIce, check out Ralf Brown's interrupt list

xor di,di

mov es,di

int 2fh

mov ax,es

add di,ax

cmp di,0

jne softice_detected



Notes:  Unlike the first two examples where a cracker could mask the device names, this VXD ID can not be changes therefore allowing for an easy detection.





Name: Interrupt 68



Description: SoftIce hooks interrupt 68 for its own use, one can use that to detect its presence.



Example:  Checks if INT68 handler was installed by SoftIce.



mov ah,43h

int 68h

cmp ax,0f386h

jnz softice_detected



Example2:  Checks the interrupt descriptor table if a handle is installed for INT68.



xor ax,ax

mov es,ax

mov bx, word ptr es:[68h*4]

mov es, word ptr es:[68h*4+2]

mov eax, 0f43fc80h

cmp eax, dword ptr es:[ebx]

jnz softice_detected



Notes: A good trick, not so simple to overcome.





Name:  INT3 detection



Description:  When a user sets a breakpoint on a certain part of the application or on an API, the debugger replaces the byte where the breakpoint is to be inserted with an INT3 (0xCC) instruction.  When the application is restarted the INT3 is executed and the debugger is triggered.



Solution: In order to protect critical sections of code the application could search the portion of code during runtime for the 0xCC op code and if detected it will be replaced with the original byte thus not triggering the debugger.  A more complex solution would be to install a new INT3 handler which will be triggered whenever a breakpoint if executed thus taking control away from the debugger and leading the attacker on to a different path.



Example:  Hooking an interrupt





;---------------------------------------------------------------------------

; SIDT stores the Interrupt Descriptor Table (IDT) Register into the specified ; operand

;------------------------------------------------------------------------------

push eax

sidt [esp-2]                  ; get pointer to the interrupt descriptor table

pop eax                 ; and get the pointer to the 32 bit base address of                           ; the table

mov ebx, 3

mov edx, 8

imul ebx, edx

add eax, ebx                  ; 3*8 bytes and eax points to the int 3 info now



;-----------------------------------

;save old INT 3 handler

;----------------------------------

mov dx, [eax+06h]           ; get the low word offset from the interrupt gate table

shl edx, 010h           ; shift into high word position in register

mov dx, [eax]     ; get the high word part of the offset from the interrupt                     ; gate table

push edx

pop OldInterruptHandler             ; save old INT 3 handler



;-----------------------------------

;insert new INT 3 handler

;-----------------------------------

mov edx, offset InterruptHandler



cli                           ; ignore maskable external interrupts

mov [eax],dx                        ; modify the high word part of the offset

shr edx,010h                        ; shift into low word position in register

mov [eax+6],dx                ; modify the low word part of the offset

sti                           ; resume responding to interrupts



ret









;---------------------------------------------------------------------------

; Restore old interrupt handler back

;---------------------------------------------------------------------------



push eax

sidt [esp-2]                  ; get pointer to the interrupt descriptor table

pop eax                 ; and get the pointer to the 32 bit base address of                           ; the table

add eax, 18h                 ; 3*8 bytes and eax points to the int 3 info now



;-----------------------------------

;insert old INT 3 handler

;-----------------------------------

mov edx, OldInterruptHandler



cli                           ; ignore maskable external interrupts

mov [eax],dx                        ; modify the high word part of the offset

shr edx,010h                        ; shift into low word position

mov [eax+6],dx                ; modify the low word part of the offset

sti                           ; resume responding to interrupts



ret





Notes:  This is a good technique and if understood could be very powerful.  Make sure to restore the old interrupt back when you are done with it.



Name: Import scanning

Description: When setting breakpoints on Windows APIs the debugger replaces the first byte in the imported function with the op code 0xCC.  A routine could be implemented to go through the import table scanning each individual imported function or selected ones for a 0xCC byte.

Notes:  Might slow an application down but could be beneficial if certain APIs are being used inside the protection scheme that if breakpointed could result in compromise.

Conclusion &#8211;

There are many different ways to detect debugging tools and the retaliation is limitless.   The best way for retaliation is to either redirect an attacker down the wrong path or just exit the application without error messages warming them of your attempts to detect their tools.