How to identify the paper names of the active printer

Problem/Question/Abstract:

How to identify the paper names of the active printer

Answer:

procedure TFReport.GetPapernames(sl: TStrings);
type
  TPaperName = array[0..63] of Char;
  TPaperNameArray = array[1..High(Integer) div Sizeof(TPaperName)] of TPaperName;
  PPapernameArray = ^TPaperNameArray;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numPaperformats: Integer;
  pPaperFormats: PPapernameArray;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPaperformats := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
  if numPaperformats > 0 then
  begin
    GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, Pchar(pPaperFormats), nil);
      sl.Clear;
      for i := 1 to numPaperformats do
        sl.add(pPaperformats^[i]);
    finally
      FreeMem(pPaperformats);
    end;
  end;
end;

Stream forms to and from disk

Problem/Question/Abstract:

I have a form that creates an advanced SQL string and I am trying to stream the entire form (TAdvanced) to disk in order to save the state of the form, and then be able to easily recall it later without having to decode the SQL string. However, after successfully (I think) streaming it to disk, I get the error "A component named PageControl1 already exists". I have tried all kinds of variations on this, but there always seems to be some conflict - either TAdvanced can't be assigned to TAdvanced or the current, or others. Any suggestions would be appreciated. Do I need to manually iterate through the components of the form and write each one in turn to the stream?

Answer:

I would use Read/ WriteComponentResFile with code similar to:

constructor TFrmPersistent.Create(AOwner: TComponent);
begin
  if FileExists('Persistent.xGS') then
  begin
    inherited CreateNew(AOwner);
    ReadComponentResFile('Persistent.xGS', self);
    self.Visible := false;
    FormCreate(self);
  end
  else
    inherited Create(AOwner);
end;

procedure TFrmPersistent.FormDestroy(Sender: TObject);
begin
  WriteComponentResFile('Persistent.xGS', self);
end;

Make Your Own Self Extractor (sfx)

Problem/Question/Abstract:

How to create an SFX (Self Extracting Executable)

Answer:

This tutorial will teach you the basics and structure of a SFX, in two parts, in theory (this file) and in practice (the project files)

STEP 1 o_o Choices [File Format]

We must take accountable what type of SFX where going to use, in this tutorial we will use the standard compression/storage standard.

Fields per Frame (File)
File Name
[Options]
  Fixed String Storage (255 Byte Standard)
    Advantages
      FAST
      EASY TO UNDERSTAND
      ZOMBIE READ (NO PROC)
    Disadvantages
      WASTED SPACE
      WASTED MEMORY
  Dynamic String Storage (1 to 256 Bytes)
    Advantages
      OPTIMAL SPACE USAGE

      LESS CHANGE OF CORRUPTION
      FASTER DOWNLOAD
      FASTER UPLOAD
    Disadvantages
      A LITTLE SLOWER
      PROCESSING READ (PROC)
Data Size [Options]
  Fixed Cardinal Storage (4 Byte Standard)
    Advantages
      FAST
      EASY TO UNDERSTAND
      ZOMBIE READ (NO PROC)
    Disadvantages
      WASTED SPACE
  Dynamic Cardinal Read (Advanced 1 - 5 Bytes)
    Advantages
      OPTIMAL SPACE USAGE
      LESS CHANCE OF CORRUPTION
      FASTER DOWNLOAD
      FASTER UPLOAD
    Disadvantages
      A LITTLE SLOWER
      PROCESSING READ (PROC)
      ADVANCED MEMORY ROUTINES  
Size Check [Options]
  Uncompressed Size (Cardinal)
    Advantages  
      FAST
      EASY
    Disadvantages
      UNSAFE
  CRC 32 (Cardinal)
    Advantages
      SAFE
      GET TO LEARN CRC32
    Disadvantages
      SLOW
      OVERKILL

You must look well into what you need and what out of the SFX to be able to choose the proper format to build, EVEN IF PEOPLE DON'T NOTICE, DO IT RIGHT!

STEP 2 o_0 Frame Format Structure Layout

Field Type Size
File Name DString 1 - 256 Bytes
Data Size Cardinal 4 Bytes
Uncompressed Size Cardinal 4 Bytes

We will introduce you step by step to the wild world of Dynamic Variables
Simple? YES
Useless? NO

Since this format doesn't have a POSITION field, we will use the old fashioned DATA HEADER approach to the SFX. This means it will be that it is meant to DUMP the files not to LOOK UP the files.

There are ways we can CONVERT this Frame Format to use in a FAT like table, but lets keep it simple (FOR NOW)

STEP 3 0_0 SFX File Format Structure

Data Type Size
SFX ID  Char 2
Frame Count Word 2
Frame Data Raw UNKNOWN
SFX Data Size Cardinal 4

SFX ID is used to detect if the executable (image file) contains valid SFX Data
Frame Count is used to tell us how many frames to process
Frame Data is the Frame Header (Structure) + Raw/Compressed File Data
SFX Data Size is NEEDED (you will see)

STEP 4 0_! How to add data to and Image File Module (EXE)

A little known fact of the all mighty image file (EXE) is that like a GOOD file format, it is that only what is specified is needed.

By that I mean that you can add what ever you want at the end and nothing will happen, no ZIP drive bursting in flames or even worse a "BLUE SCREEN" (c) Micro$oft 1991-2002

Now you see why I need the SFX Length at the END? yes its to go to the end of the READ-ONLY Image File (EXE) and read the Length, then look up the SFX ID to see if any SFX data is present on that Image File (EXE)

STEP 5 !_! Now to build an SFX module

Well this is an easy and important part of the process, make it as SMALL as POSSIBLE, yes kiddies

"YOU CAN PACK THE IMAGE FILE (EXE)"
TIP: UPX is great for SFX MODULES

Use less DELPHI libraries as possible, API is the way to go!
but since this is a intro tutorial we MUST make it simple.

Make a procedure to read and process the data,
in this case we can use it to READ, UNCOMPRESSED, WRITE the files.

FINAL STEP CODING!

How to read and write a Dynamic String

function ReadDString(Stream: TStream): string;
var

  LEN: Byte; // Length Byte

begin

  Stream.Read(LEN, 1); // Read Length (255 Max)
  SetLength(Result, LEN); // Set Delphi D-String Array Size
  Stream.Read(PChar(Result)^, LEN); // Read Data to D-String Array

end;

procedure WriteDString(Stream: TStream; const Str: string);
var

  LEN: Byte; // Length Byte

begin

  LEN := Length(Str); // Set Length Byte what Str[0] used to be
  Stream.Write(LEN, 1); // Write Length Byte (255 Max)
  Stream.Write(PChar(Str)^, LEN); // Write D-String Array Data

end;

COMMENT

Why the "PChar(Str)^" why not just use Str?
Well since the Str is a Delphi Dynamic-String Array (array of char), it stores its pointer, so if you attempt to use Str you are actually writing its pointer NOT the data, so what i do is I get the Pointer of the first Character on the array "PChar(Str)" then I release it as a VARIABLE or CONSTANT, as if it where a normal variable!.

Download

Download project files for both the SFX Maker and the SFX it self
it is your job to try to understand the code, (i re-use variables allot), the main idea is this:

CREATE NEW SFX FILE
WRITE SFX MODULE (MODULE EXE)
WRITE SFX DATA

SFX DATA
WRITE ID ('SF')
WRITE FILE COUNT
WRITE FILE
WRITE LENGTH

WRITE FILE
WRITE FILENAME
WRITE COMPRESSED LENGTH
WRITE UNCOMPRESSED LENGTH
WRITE COMPRESSED FILE DATA


Component Download: http://www.taxisairport.com/dhype/downloads/sfxtutorial.rar

Dropping Tables from MS SQL Server with Delphi

Problem/Question/Abstract:

How do I go about dropping Tables from MS SQL Server with Delphi

Answer:

I've been doing extensive work with Client/Server Delphi and MS SQL Server as my back-end database. The operational model that I use for my Client/Server is that the client application acts only as local interface, and that all queries and calculations - even temporary files - are performed or created on the server. Now this presents a couple of problems in that garbage cleanup isn't quite as easy as it is when using local tables as temporary files.

For instance, a lot of my programs create temporary files that I either reference later in the program or that I use as temporary storage for outer joins. Once I'm done with them, I need to delete them. With local tables, it's a snap. Just get a list of the tables, and with a little bit of code that uses some Windows API calls, delete them. Not so easy with SQL Server tables. The reason why is that you have to go through the BDE to accomplish the task - something that's not necessarily very intuitive. Luckily, however, it doesn't involve low-level BDE API calls.

Below is a procedure listing that drops tables from any SQL Server database. After the listing I'll discuss particulars...

Parameter Descriptions

//var Ses : TSession;         //A valid, open session
//DBName : String;            //Name of the SQL Server DB
//ArTables : array of String; //An array of table names
//StatMsg : TStatusMsg);      //A status message callback
                             //procedure

TStatusMsg is a procedural type used as a callback procedure

type
  TStatusMsg = procedure(Msg: string);

procedure DropMSSQLTempTables(var Ses: TSession;
  DBName: string;
  ArTables: array of string;
  StatMsg: TStatusMsg);
var
  N: Integer;
  qry: TQuery;
  lst: TStringList;
begin
  lst := TStringList.Create;

  Ses.GetTableNames(DBName, '', False, False, lst);

  try
    for N := Low(arTables) to High(arTables) do
      if (lst.IndexOf(ArTables[N]) > 0) then
      begin
        StatMsg('Removing ' + arTables[N] +
          ' from client database');
        qry := TQuery.Create(nil);
        with qry do
        begin
          Active := False;
          SessionName := Ses.SessionName;
          DatabaseName := DBName;
          SQL.Add('DROP TABLE ' + arTables[N]);
          try
            ExecSQL;
          finally
            Free;
            qry := nil;
          end;
        end;
      end;
  finally
    lst.Free;
  end; { try/finally }
end;

The pseudo-code for this is pretty easy.

Get a listing of all tables in the SQL Server database passed to the procedure.
Get a table name from the table name array.
If a passed table name happens to be in the list of table retrieved from the database, DROP it.
Repeat 2. and 3. until all table names have been exhausted.

The reason why I do the comparison in step 3 is because if you issue a DROP query against a non-existent table, SQL Server will issue an exception. This methodology avoids that issue entirely.

Below is a detailed description of the parameters.

Parameter Name
Type
Description
Ses
var TSession
This is a session instance variable that you pass by reference into the procedure. Note: It MUST be instantiated prior to use. The procedure does not create an instance. It assumes it already exists. This is especially necessary when using this procedure within a thread. But if you're not creating a multi- threaded application, then you can use the default Session variable.
DBName
String
Name of the MS SQL Server client database
ArTables
Array of String
This is an open array of string that you can pass into the procedure. This means that you can pass any size array and the procedure will handle it. For instance, in the Primary table maker program, I define an array as follows:

arPat[0] := 'dbo.Temp0';
arPat[1] := 'dbo.Temp1';
arPat[2] := 'dbo.Temp2';
arPat[3] := 'dbo.Temp3';
arPat[4] := 'dbo.Temp4';
arPat[5] := 'dbo.Temp5';
arPat[6] := 'dbo.PatList';
arPat[7] := 'dbo.PatientList';
arPat[8] := 'dbo.EpiList';
arPat[9] := 'dbo.' + FDisease + 'CrossTbl_' + FQtrYr;
arPat[10] := 'dbo.' + FDisease + 'Primary_' + FQtrYr;

and pass it into the procedure.
StatMsg
TStatusMsg
This is a procedural type of : procedure(Msg : String). You can’t use a class method for this procedure; instead, you declare a regular procedure that references a regular procedure. For example, I declare an interface-level procedure called StatMsg that references a thread instance variable and a method as follows:

procedure StatMsg(Msg: string);
begin
  thr.FStatMsg := Msg;
  thr.Synchronize(thr.UpdateStatus);
end;

The trick here is that "thr" is the instance variable used to instantiate my thread class. The instance variable resides in the main form of my application. This means that it too must be declared as an interface variable.


I'm usually averse to using global variables and procedures. It's against structured programming conventions. However, what this procedure buys me is the ability to place it in a centralized library and utilize it in all my programs.

Before you use this, please make sure you review the table above. You need to declare a type of TStatusMsg prior to declaring the procedure. If you don't, you'll get a compilation error.

Query result into a string list

Problem/Question/Abstract:

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Answer:

Have you ever needed to load the result of a query into a string ?
Here's how to load the result of a query into a string list.

Let's say we have a table named 'Contact' which holds the fields 'first_name', 'last_name', 'phone', 'salutation'.
Let's say you just need to load these result once into your application, you can either keep a permanent connection to access the data or you can load it once, or whenever necessary, into memory and then free the connection.

Let's choose to load the data into memory, otherwise this article would not have any reason for existing! :)

What I show here is a very simple "trick", using a TQuery and TStringList, I show how to load each record from the TQuery's result set into a string of the TStringList.
So, let's say we need the last name and from the contact table.
You know a simple

SELECT last_name FROM contact

will do the job, all you need to do is to loop the result and add it to the string list.
But, how about if we need the salutation, last name and contact fields all at once in only one string ?  Well, the solution is also simple, for record a loop through the requeted attributes is also done!

Before I show the code to do this simple task, I'll explain how it will be achieved:

1. Receiver the database name, table name, attributes, field separator and a string list.
2. Split the attributes string into a list of strings
3. Run the database query
4. Loop in the result set
4.1. For each result set, loop the attributes
4.2. Add all attributes from the result set into the string list

And now, a possible implementation of this:

You will require these units: dbtables, stdctrls and classes.

// - One Attribute for each array position, sequentially -

procedure FillRecordSL(DBName, T, A, C, FS: string; var SL: TStringList);
var
  Attrs: TStringList;
  F: ShortInt;

  // - Split Attributes -
  procedure SplitAttributes(A: string; var Attrs: TStringList);
  var
    X: Integer;
    S: string;
  begin
    if not (Assigned(Attrs)) then
      Attrs := TStringList.Create;

    S := '';
    X := 1;
    while (X <= Length(A)) do
    begin
      if (A[X] = ',') then
      begin
        Attrs.Add(Trim(S));
        S := '';
      end
      else
        S := S + A[X];

      Inc(X);
    end;
    Attrs.Add(Trim(S + A[X]));

  end;

begin
  Attrs := TStringList.Create;
  SlitAttributes(A, Attrs);

  with TQuery.Create(nil) do
  begin
    DatabaseName := DBName;
    FilterOptions := [foCaseInsensitive];
    SQL.Add('SELECT ' + A + ' FROM ' + T);
    if Length(C) > 0 then
      SQL.Add('WHERE ' + C);
    Prepare;
    while not (Prepared) do
      ;
    Open;
    First;
    try
      while not (EOF) do
      begin
        AuxStr := '';
        for F := 0 to Attrs.Count - 1 do
          AuxStr := AuxStr + FS + Fields[F].AsString;
        Delete(AuxStr, 1, Length(FS));
        SL.Add(AuxStr);
        Next;
      end;
      Close;
    finally
      Free;
    end;
  end;

  Attrs.Free;
end;

Let's assume that your database name is MyDB and you already have a SL variable of type TStringList.
Now some examples, to access the salutation, last name and contact, all you have to do is to call the procedure this way:

FillRecordSL('MyDB', 'contact', 'salutation, last_name, contact', '', ' ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Mr. Kong 098765432'
SL[1] = 'Mrs. Chita 098765431'
SL[2] = 'Miss Tarzan 123456789'

FillRecordSL('MyDB', 'contact', 'salutation, first_name, last_name, contact',
  'salutation = ''Mrs.''', '; ', SL);

Now the SL varibale helds someting like this:

SL[1] = 'Mrs.; Mila; Chita; 098765431'

FillRecordSL('MyDB', 'contact', 'last_name, first_name, contact', '', ', ', SL);

Now the SL varibale helds someting like this:

SL[0] = 'Kong, King, 098765432'
SL[1] = 'Chita, Mila, 098765431'
SL[2] = 'Tarzan, Jane, 123456789'

You can expand this procedure to increase its capabilities, what I ment to show here was just a starting point.
Hope it helps you.

Data Encryption - How It Works...

Problem/Question/Abstract:

How does Data Encryption Work

Answer:

Encryptions Early Predecessors
&#8220;Since man was created, war began&#8221;

A little known fact is that even since the days of the Greeks- Encryption was a priority, people trying to stay one step ahead of there rivals, Text Messages where good as gold and a great way to communicate, but in war it is an indispensable tool but not so secure.

the &#8220;Cesar&#8221; cipher is a good example, Cesar used a very simple but effective method for protecting his messages that where sent to his army.

Normal

ABCDEFGHIJKLMNOPQRSTUVWXYZ

Coded

EFGHIJKLMNOPQRSTUVWXYZABCD

The letters where shifted left 4 spaces

A message might look like this:

MCFVNH

Meaning this:

HYBRID

Even in the early 1900&#8217;s the USA used a similar form to communicate with its troops, a BOOK a Paragraph was used as the CODEC, starting by logging the letters so they wouldn&#8217;t repeat them self&#8217;s:

For example:

&#8220;IT WAS THE BEST OF TIMES, IT WAS THE WORST OF TIMES&#8221;

The letters get logged starting from the beginning.

&#8220;IT &#8221; = &#8220;AB&#8221;

&#8220;WAS&#8221; = &#8220;CDE&#8221;

&#8220;THE&#8221; = &#8220;BFG&#8221;

Notice that the &#8216;T&#8217; got repeated so its value is still &#8216;B&#8217; and so on.

How Data Gets Encrypted
&#8220;The virtual age&#8221;

Now encryption changed thanks to computers, since the birth of the all mighty BYTE one single change and you have a whole new number.

Now a BYTE is made of 8 BITS

8-7-6-5-4-3-2-1

each BIT has a value (the double of the last) assigned to it

128-64-32-16-8-4-2-1

The max value of a BYTE is 255 (the sum of all the BITS)

Logical operators are used to modify the bits in a byte or more

OR

(Add)


The OR operator is used to set the BITS in a value. example:

If you decided to OR the value: 4

(00000100)

with the value: 2

(00000010)

the result will be the number 6

(00000110)

since the sum of the 3rd BIT and the 2nd BIT gives us 6


AND

(Extract)


The AND operator is used to check if the BITS in a VALUE are set.

If you decided to AND the value: 4

(00000100)

with the value: 8

(00001000)

the result will be the number 0

(00000000)

Since the value 8 (the 4th BIT) is not set

If the BIT where set

the result will be the number 8 (AGAIN)

(00001000)


XOR

(Toggle)


The all mighty XOR operator is used to toggle the BITS in a VALUE (1=0 and 0=1)

If you decided to XOR the value: 255

(11111111)

with the value: 4

(00000100)

the result will be the number 251

(11111011)

The all the BITS in the value where toggled now if we repeat the process with the last result (251)

(11111011)

with the value: 4

(00000100)

the result will be the number 255 again

(11111111)

Now you see why the XOR is used so much, since you need not remember the original value only the KEY or in this case the 4

All values that you XOR are changed BIT by BIT so if you use a VALUE (KEY) lower than the DATA you will only change the first bytes in that value

For example an Integer (123456789) uses 4-Bytes and the value 90210 uses 2-Bytes, so if you XOR 123456789 with 90210 the changes will only affect the first 2-Bytes.

Random numbers are great but you must find a better way to generate them, since most Compilers have there own way of generating them (using the TIME is the most common) the DATA may get lost or corrupted easily.

Now the most popular is the PGP type of Encryption that I will explain later,

But first we need to explain how to generate a GOOD and SAFE key

Data Types
&#8220;One spoon or two&#8221;

The key as well as the data gets split in different data sets for example you can toggle 1 byte / 2 bytes (word) / 4 bytes (W32 Integer) / 8 bytes (int64). This way you can toggle more data and take less time. But you must always remember where your algorithm is going to be used; some systems can&#8217;t handle a 64bit Integer (some handhelds, etc). And a must is to always pair up the data size with the key size, you don&#8217;t want to encrypt text and leave readable hole.

Cipher Logic
&#8220;Lose your self in the numbers&#8221;

A KEY is always important, the time for the magical &#8220;SWORDFISH&#8221; password has ended; now you need not remember a single word but the less similar to a WORD the better.

A good KEY is longer than 128-BITS (32 BYTES/CHARS)

It is always recommended to use the full 8-BITS in each BYTE rather than just the ones used for the &#8216;Letter Characters&#8217;, the less repetitive the better.

Yes in the case of some PGP like keys they can still use the small passwords, that is because the DATA is not encrypted with the key it self instead it is Encrypted with a Session key, that key is created via any temporary data on the machine, memory, mouse position, windows version, etc.

And then the Session key is encrypted with the user key. In the case of PGP the Session key is encrypted with the Public Key.

Predetermined Keys
&#8220;Does size REALLY matter&#8221;

One of the best ways to encrypt data is to use predetermined

Keys for example the well known BLOWFISH and TWOFISH use this technique as well as many others. The USER KEY gets split in multiple sections that are used to toggle the Predetermined Keys, which in turn toggle the data in various passes.

Time and Time Again
&#8220;Shake well&#8221;

The best technique is to toggle the same part more than once, in most cases 16 times is enough. Another use for this is to shred data like most programs you can scramble the data so much that it will become unrecognizable to any data recovery program, others just zero-out the bytes, but in most cases the data on a disk can still be recovered if it was just zeroed, the Hard Disk leaves a small trace or residue of the last value there (un-format for example).

Cover your tracks
&#8220;Crouching Tiger, Hidden Footprint&#8221;

Now it is best to learn assembler for this but any language will do, since time is of the essence, I use assembler, to cover your tracks it is best to add fake procedures or moves like shifting and switching variables, in the event that a cracker might want to break the encryption. Now a days it is useless since the world revolves around keys, the cracker can have the code but not the data.

Ensure that every node in a TTreeView is unique (2)

Problem/Question/Abstract:

I have a 3 level TTreeview. The nodes in levels 2 and 3 must have unique captions (text). Items will be added in a loop so I can't check the "Selected" text against the data to be entered. However, I will know which node where data entry will begin. If adding child nodes to a node on level 2 for example, I assume I need to loop through the children of the particular parent node of the node on level 2 and check the text property? Does this make sense?

Answer:

Yes. Use the edited nodes Parent.GetfirstChild to get a reference to the first child node of that parent. Then use that nodes GetNextSibling to find the next node on that level to examine, and so on. Untested:

function IsDuplicateNode(aNode: TTreenode): Boolean;
var
  walker: TTreenode;
begin
  Assert(Assigned(aNode), 'Need a node to examine!');
  if Assigned(aNode.Parent) then
    walker := aNode.Parent.GetFirstChild
  else
    walker := TTreeview(aNode.Treeview).Items[0];
  Result := False;
  while Assigned(walker) do
  begin
    if (walker <> aNode) and AnsiSametext(walker.Text, aNode.Text) then
    begin
      Result := true;
      Break;
    end;
    walker := walker.GetNextSibling;
  end;
end;

How to get the PopupPoint of a TPopupMenu

Problem/Question/Abstract:

I have a popup menu assigned to a TListView. I'm trying to get the ListItem where the right click occured. I can not get the coords where the popup click happened due to the fact that PopupMenu.PopupPoint is protected.

Answer:

type
  TCrackPopupMenu = class(TPopupMenu)
  end;

procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
  pt: TPoint;
begin
  pt := TCrackPopupMenu(PopupMenu1).PopupPoint;
  Label1.Caption := Format('Popped up at: X = %d, Y = %d', [pt.x, pt.y]);
end;

By the way, PopupPoint returns screen coordinates.

Registering a file type on Windows 9x/2000/NT

Problem/Question/Abstract:

Registering a file type on Windows 9x/2000/NT

Answer:

This is typically the task of an installer like Wise or InstallShield, buy you may be in a situation where you have to do it manually.

Registering an application to handle a certain file type means putting a few entries in the registry. Just use the function from the code below.

program RegisterExt;

uses
  Registry;

procedure RegisterExtension(
  const sAppName: string;
  const sAppPath: string;
  const sIconName: string;
  const sExtension: string);
var
  Reg: TRegistry;
begin { RegisterExtension }
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.ext', True);
    WriteString('', sAppName);
    CloseKey;
    OpenKey(sAppName, True);
    WriteString('', sAppName);
    OpenKey('DefaultIcon', True);
    WriteString('', sIconName);
    CloseKey;
    OpenKey(sAppName + '\shell\open\command', True);
    WriteString('', sAppPath);
    CloseKey;
    Free;
  end { with Reg };
end; { RegisterExtension }

begin
  RegisterExtension('MyGreatApplication',
    'c:\program files\mystuff\myApp.exe',
    'c:\program files\mystuff\myApp.ico',
    '.shl');
end.

How to create a status bar that displays the system's time, date and keyboard status

Problem/Question/Abstract:

How to create a status bar that displays the system's time, date and keyboard status

Answer:

unit Status;

interface

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

type
  TStatus = class(TCustomPanel)
  private
    FDate: Boolean;
    FKeys: Boolean;
    FTime: Boolean;
    FResources: Boolean;
    DateTimePanel: TPanel;
    ResPanel: TPanel;
    ResGauge: TGauge;
    CapPanel: TPanel;
    NumPanel: TPanel;
    InsPanel: TPanel;
    HelpPanel: TPanel;
    UpdateWidth: Boolean;
    FTimer: TTimer;
    procedure SetDate(A: Boolean);
    procedure SetKeys(A: Boolean);
    procedure SetTime(A: Boolean);
    procedure SetResources(A: Boolean);
    procedure SetCaption(A: string);
    function GetCaption: string;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetupPanelFields(ThePanel: TPanel);
    procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
    procedure UpdateStatusBar(Sender: TObject);
  published
    property ShowDate: Boolean read FDate write SetDate default True;
    property ShowKeys: Boolean read FKeys write SetKeys default True;
    property ShowTime: Boolean read FTime write SetTime default True;
    property ShowResources: Boolean read FResources write SetResources default True;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderStyle;
    property BorderWidth;
    property Caption: string read GetCaption write SetCaption;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3d;
    property ParentFont;
    property ParentShowHint;
    property PopUpMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TStatus]);
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin
  with ThePanel do
  begin
    Alignment := taCenter;
    Caption := '';
    BevelInner := bvLowered;
    BevelOuter := bvNone;
    {Set all these true so they reflect the settings of the TStatus}
    ParentColor := True;
    ParentFont := True;
    ParentCtl3D := True;
  end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
begin
  SetupPanelFields(ThePanel);
  with ThePanel do
  begin
    Width := Canvas.TextWidth(WidthMask);
    Align := alRight;
  end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := TWinControl(AOwner);
  FTime := True;
  FDate := True;
  FKeys := True;
  FResources := True;
  {Force the status bar to be aligned bottom}
  Align := alBottom;
  Height := 19;
  BevelInner := bvNone;
  BevelOuter := bvRaised;
  {When UpdateWidth is set TRUE, status bar will recalculate panel widths once}
  UpdateWidth := True;
  Locked := True;
  TabOrder := 0;
  ;
  TabStop := False;
  Font.Name := 'Arial';
  Font.Size := 8;
  {Create the panel that will hold the date and time}
  DateTimePanel := TPanel.Create(Self);
  DateTimePanel.Parent := Self;
  SetupPanel(DateTimePanel, '  00/00/00 00:00:00 am  ');
  {Create the panel that will hold the resources graph}
  ResPanel := TPanel.Create(Self);
  ResPanel.Parent := Self;
  SetupPanel(ResPanel, '                    ');
  {Create the 2 Gauges that will reside within the Resource Panel}
  ResGauge := TGauge.Create(Self);
  ResGauge.Parent := ResPanel;
  ResGauge.Align := alClient;
  ResGauge.ParentFont := True;
  ResGauge.BackColor := Color;
  ResGauge.ForeColor := clLime;
  ResGauge.BorderStyle := bsNone;
  {Create the panel that will hold the CapsLock state}
  CapPanel := TPanel.Create(Self);
  CapPanel.Parent := Self;
  SetupPanel(CapPanel, '  Cap  ');
  {Create the panel that will hold the NumLock state}
  NumPanel := TPanel.Create(Self);
  NumPanel.Parent := Self;
  SetupPanel(NumPanel, '  Num  ');
  {Create the panel that will hold the Insert/Overwrite state}
  InsPanel := TPanel.Create(Self);
  InsPanel.Parent := Self;
  SetupPanel(InsPanel, '  Ins  ');
  {Create the panel that will hold the status text}
  HelpPanel := TPanel.Create(Self);
  HelpPanel.Parent := Self;
  SetupPanelFields(HelpPanel);
  {Have the help panel consume all remaining space}
  HelpPanel.Align := alClient;
  HelpPanel.Alignment := taLeftJustify;
  {This is the timer that will update the status bar at regular intervals}
  FTimer := TTimer.Create(Self);
  if FTimer <> nil then
  begin
    FTimer.OnTimer := UpdateStatusBar;
    {Updates will occur twice a second}
    FTimer.Interval := 500;
    FTimer.Enabled := True;
  end;
end;

destructor TStatus.Destroy;
begin
  FTimer.Free;
  HelpPanel.Free;
  InsPanel.Free;
  NumPanel.Free;
  CapPanel.Free;
  ResGauge.Free;
  ResPanel.Free;
  DateTimePanel.Free;
  inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin
  FDate := A;
  UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin
  FKeys := A;
  UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin
  FTime := A;
  UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin
  FResources := A;
  UpdateWidth := True;
end;

{When we set or get the TStatus caption, it is affecting the HelpPanel caption instead}

procedure TStatus.SetCaption(A: string);
begin
  HelpPanel.Caption := ' ' + A;
end;

function TStatus.GetCaption: string;
begin
  GetCaption := HelpPanel.Caption;
end;

{This procedure sets the captions appropriately}

procedure TStatus.UpdateStatusBar(Sender: TObject);
begin
  if ShowDate and ShowTime then
    DateTimePanel.Caption := DateTimeToStr(Now)
  else if ShowDate and not ShowTime then
    DateTimePanel.Caption := DateToStr(Date)
  else if not ShowDate and ShowTime then
    DateTimePanel.Caption := TimeToStr(Time)
  else
    DateTimePanel.Caption := '';
  if UpdateWidth then
    with DateTimePanel do
      if ShowDate or ShowTime then
        Width := Canvas.TextWidth('  ' + Caption + '  ')
      else
        Width := 0;
  if ShowResources then
  begin
    ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
    if ResGauge.Progress < 20 then
      ResGauge.ForeColor := clRed
    else
      ResGauge.ForeColor := clLime;
  end;
  if UpdateWidth then
    if ShowResources then
      ResPanel.Width := Canvas.TextWidth('                    ')
    else
      ResPanel.Width := 0;
  if ShowKeys then
  begin
    if (GetKeyState(vk_NumLock) and $01) <> 0 then
      NumPanel.Caption := '  Num  '
    else
      NumPanel.Caption := '';
    if (GetKeyState(vk_Capital) and $01) <> 0 then
      CapPanel.Caption := '  Cap  '
    else
      CapPanel.Caption := '';
    if (GetKeyState(vk_Insert) and $01) <> 0 then
      InsPanel.Caption := '  Ins  '
    else
      InsPanel.Caption := '';
  end;
  if UpdateWidth then
    if ShowKeys then
    begin
      NumPanel.Width := Canvas.TextWidth(' Num ');
      InsPanel.Width := Canvas.TextWidth(' Ins ');
      CapPanel.Width := Canvas.TextWidth(' Cap ');
    end
    else
    begin
      NumPanel.Width := 0;
      InsPanel.Width := 0;
      CapPanel.Width := 0;
    end;
  UpdateWidth := False;
end;

{This allows font changes to be detected so the panels will be adjusted}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin
  inherited;
  UpdateWidth := True;
end;

end.

interface

implementation

end.

How to transfer data between a TDBGrid and the clipboard

Problem/Question/Abstract:

How to transfer data between a TDBGrid and the clipboard

Answer:

The grid must be in Edit or Insert mode for the paste to work.

Add 'ClipBrd' to the Uses list
Add 'gk: Word;' to your global variables
Add the following procedures to Implementation, substituting names as required

procedure TMyForm.MyDBGridKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
{OnKeyDown event handler for your DBGrid}
const
  vk_c = $43;
  vk_v = $56;
begin
  if Shift = [ssCtrl] then
  begin
    if key = vk_v then
      Shift := [ssShift];
    if (key = vk_c) or (key = vk_v) then
    begin
      gk := Key;
      key := 0;
    end;
  end;
end;

procedure TMyForm.MyDBGridKeyPress(Sender: TObject; var Key: Char);
{OnKeyPress event handler for your DBGrid}
const
  vk_c = $43;
  vk_v = $56;
begin
  if gk <> 0 then
  begin
    Key := chr(0);
    if gk = vk_c then
      ClipBoard.AsText := MyTable.Fields[MyDBGrid.SelectedIndex].AsString;
    if gk = vk_v then
    begin
      if (MyTable.State = dsEdit) or (MyTable.State = dsInsert) then
        MyTable.Fields[MyDBGrid.SelectedIndex].AsString := ClipBoard.AsText
      else
        MessageBeep(0);
    end;
    gk := 0;
  end;
end;

How to avoid palette problems with a TImage / TBitmap

Problem/Question/Abstract:

I have written an D 4.0 application that opens a jpeg, paints it to a TImage canvas, alters the TImage, and then saves the TImage back to a new jpeg file. The application works great on the development machine, however when installing it on another machine (using IS 2) it generates incorrect pictures. The jpeg are displayed correctly. When I draw to the canvas the picture is also correct. However when the image is saved to a new file the original portion of the image looks like garbage, however the portion that was added is correct. I can't find any dependencies listed that need to get distributed. Did I miss something?

Answer:

First of all, the canvas of a TImage is not meant to be written on by anyone else but the image the TImage contains. Also, this sounds like a palette problem. If so, your development machine probably doesn't use palettes (16,24 or 32 bit color depth) and your test machine uses palettes (8 bit color depth). Try something like this instead (not tested):

procedure DrawBitmapOnJPEG(JPEG: TJPEGImage; BMP: TBitmap);
var
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    { Convert JPEG to bitmap (DIB hopefully) }
    Bitmap.Assign(JPEG);
    { Avoid palette problems }
    Bitmap.PixelFormat := pf24bit;
    { Draw BMP on JPEG }
    Bitmap.Canvas.Draw(0, 0, BMP);
    { Convert bitmap back to JPEG }
    JPEG.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

Invisible title - hide the program's title bar

Problem/Question/Abstract:

Invisible title - hide the program's title bar

Answer:

This is a quick way to hide your program's title bar:

procedure TForm1.FormCreate(Sender: TObject);
var
  OldStyle: longint;
begin
  OldStyle := GetWindowLong(Handle, GWL_STYLE);
  SetWindowLong(Handle, GWL_STYLE, OldStyle and not WS_CAPTION);
  ClientHeight := Height;
end;

Copy the current record of a dataset

Problem/Question/Abstract:

Copy the current record of a dataset

Answer:

I found this routine which copies the current record of the currently selected record. This is useful e.g. to keep a temporary record for display in a form.

{************************************************
// procedure AppendCurrent
//
// Will append an exact copy of the current
// record of the dataset that is passed into
// the procedure and will return the dataset
// in edit state with the record pointer on
// the currently appended record.
************************************************}

procedure AppendCurrent(Dataset: Tdataset);
var
  aField: Variant;
  i: Integer;
begin
  // Create a variant Array
  aField := VarArrayCreate(
    [0, DataSet.Fieldcount - 1],
    VarVariant);
  // read values into the array
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    aField[i] := DataSet.fields[i].Value;
  end;
  DataSet.Append;
  // Put array values into new the record
  for i := 0 to (DataSet.Fieldcount - 1) do
  begin
    DataSet.fields[i].Value := aField[i];
  end;
end;