Copy your form to the clipboard

Problem/Question/Abstract:

Put the form contents in the clipboard.

Answer:

Add 'Clipbrd' in the uses of your form
Put this code in the OnClick of a TButton

procedure TForm1.Button1Click(Sender: TObject);
var bitmap:tbitmap;
begin
  bitmap:=tbitmap.create;
  bitmap.width:=clientwidth;
  bitmap.height:=clientheight;
  try
    with bitmap.Canvas do
      CopyRect (clientrect,canvas,clientrect);
    clipboard.assign(bitmap);
  finally
    bitmap.free;
  end;
end;

How to convert a cursor file into a bitmap

Problem/Question/Abstract:

How to convert a cursor file into a bitmap

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  hCursor: LongInt;
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  Bitmap.Width := 32;
  Bitmap.Height := 32;
  hCursor := LoadCursorFromFile('test.cur');
  DrawIcon(Bitmap.Canvas.Handle, 0, 0, hCursor);
  Bitmap.SaveToFile('test.bmp');
  Bitmap.Free;
end;

Launch a Windows open file dialog without using the standard Delphi dialog component

Problem/Question/Abstract:

Is there an API call or other to launch a Windows open file dialog without using the standard delphi dialog component? I call a function "Hooklock1" from:

keyHook := SetWindowsHookEx(WH_KEYBOARD, HookLock1, HInstance, 0);

In this function no references to delphi global variables or components seem to work, I need to call an open dialog box to specify a filename. Any ideas?

Answer:

procedure TForm1.OpenApiClick(Sender: TObject);
var
  OpenFile: TOpenFileName;
begin
  with OpenFile do
  begin
    lStructSize := SizeOf(TOpenFilename);
    hInstance := SysInit.HInstance;
    hWndOwner := {Application.} Handle;
    lpstrFilter := 'Text Files (*.txt)' + Chr(0) + '*.txt' + Chr(0) +
                'All Files (*.*)' + Chr(0) + '*.*' + Chr(0);
    nFilterIndex := 1;
    {create a buffer for the file}
    nMaxFile := 255;
    lpstrFile := PChar(StringOfChar(' ', nMaxFile - 1));
    {create a buffer for the file title}
    nMaxFileTitle := 255;
    lpstrFileTitle := PChar(StringOfChar(' ', nMaxFileTitle - 1));
    {set the initial directory}
    lpstrInitialDir := 'C:\';
    lpstrTitle := 'Open a file, please';
    Flags := OFN_EXPLORER;
  end;
  if not GetOpenFileName(OpenFile) then
    Exit;
end;

ISAPI Filter Header Files

Problem/Question/Abstract:

In regard to my article "Writing a simple ISAPI Filter for IIS". here you can find the whole translation of the ISAPI Filter Header file HttpFilt.h.

Answer:

Some time ago I wrote an article about ISAPI Filters. Back then I promised to publish the whole translation of the ISAPI Header files. Somehow I never got around to do them, so finally, here they are.

For questions on how to use this definitions refer to my old article, please "Writing a simple ISAPI Filter for IIS".

Some of the definitions may have changed, due to my personal development during the last months, most, however should work as expected. I hope to submit this header translations for the Delphi-Jedi project some time soon.

NOTE: I know that Borland has some of the definitions in the unit Isapi2.pas, however, there are some important changes since version 2. This version depends upon version 4 from Microsoft.

There you go:

{************************************************************************}
{                                                                        }
{       Borland Delphi Runtime Library                                   }
{       HTTP Filter interface unit                                       }
{                                                                        }
{ Portions created by Microsoft are                                      }
{ Copyright (C) 1997 Microsoft Corporation.                              }
{ All Rights Reserved.                                                   }
{                                                                        }
{ The original file is: httpext.h, released 27 January 1999.             }
{ The original Pascal code is: httpext.pas, released 29 April 2002.      }
{ The initial developer of the Pascal code is Daniel Wischnewski         }
{ (daniel@wischnewski.tv).                                               }
{                                                                        }
{ Portions created by Daniel Wischnewski are                             }
{ Copyright (C) 2002 Daniel Wischnewski.                                 }
{                                                                        }
{       Obtained through:                                                }
{                                                                        }
{       Joint Endeavour of Delphi Innovators (Project JEDI)              }
{                                                                        }
{ The contents of this file are used with permission, subject to         }
{ the Mozilla Public License Version 1.1 (the "License"); you may        }
{ not use this file except in compliance with the License. You may       }
{ obtain a copy of the License at                                        }
{ http://www.mozilla.org/MPL/MPL-1.1.html                                }
{                                                                        }
{ Software distributed under the License is distributed on an            }
{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or         }
{ implied. See the License for the specific language governing           }
{ rights and limitations under the License.                              }
{                                                                        }
{************************************************************************}

unit HttpFilt;

{$WEAKPACKAGEUNIT}

interface

{$HPPEMIT ''}
{$HPPEMIT '#include "httpfilt.h"'}
{$HPPEMIT '#include "windows.h"'}
{$HPPEMIT ''}

uses
  Windows;

type
  PVOID = Pointer;
{$EXTERNALSYM PVOID}
  LPVOID = Pointer;
{$EXTERNALSYM LPVOID}
  LPSTR = PChar;
{$EXTERNALSYM LPSTR}

  //
  //  Current version of the filter spec is 4.0
  //
const
  HTTP_FILTER_REVISION = WORD(0) + DWORD(4 shl 16);
{$EXTERNALSYM HTTP_FILTER_REVISION}
  SF_MAX_USERNAME = 256 + 1;
{$EXTERNALSYM SF_MAX_USERNAME}
  SF_MAX_PASSWORD = 256 + 1;
{$EXTERNALSYM SF_MAX_PASSWORD}
  SF_MAX_AUTH_TYPE = 32 + 1;
{$EXTERNALSYM SF_MAX_AUTH_TYPE}
  SF_MAX_FILTER_DESC_LEN = 256 + 1;
{$EXTERNALSYM SF_MAX_FILTER_DESC_LEN}

  //
  //  These values can be used with the pfnSFCallback function supplied in
  //  the filter context structure
  //

const
  //
  //  Sends a complete HTTP server response header including
  //  the status, server version, message time and MIME version.
  //
  //  Server extensions should append other information at the end,
  //  such as Content-type, Content-length etc followed by an extra
  //  '\r\n'.
  //
  //  pData - Zero terminated string pointing to optional
  //      status string (i.e., "401 Access Denied") or NULL for
  //      the default response of "200 OK".
  //
  //  ul1 - Zero terminated string pointing to optional data to be
  //      appended and set with the header.  If NULL, the header will
  //      be terminated with an empty line.
  //
  SF_REQ_SEND_RESPONSE_HEADER = 0;
  //
  //  If the server denies the HTTP request, add the specified headers
  //  to the server error response.
  //
  //  This allows an authentication filter to advertise its services
  //  w/o filtering every request.  Generally the headers will be
  //  WWW-Authenticate headers with custom authentication schemes but
  //  no restriction is placed on what headers may be specified.
  //
  //  pData - Zero terminated string pointing to one or more header lines
  //      with terminating '\r\n'.
  //
  SF_REQ_ADD_HEADERS_ON_DENIAL = 1;
  //
  //  Only used by raw data filters that return SF_STATUS_READ_NEXT
  //
  //  ul1 - size in bytes for the next read
  //
  SF_REQ_SET_NEXT_READ_SIZE = 2;
  //
  //  Used to indicate this request is a proxy request
  //
  //  ul1 - The proxy flags to set
  //      0x00000001 - This is a HTTP proxy request
  //
  //
  SF_REQ_SET_PROXY_INFO = 3;
  //
  //  Returns the connection ID contained in the ConnID field of an
  //  ISAPI Application's Extension Control Block.  This value can be used
  //  as a key to cooridinate shared data between Filters and Applications.
  //
  //  pData - Pointer to DWORD that receives the connection ID.
  //
  SF_REQ_GET_CONNID = 4;
  //
  // Used to set a SSPI security context + impersonation token
  // derived from a client certificate.
  //
  // pData - certificate info ( PHTTP_FILTER_CERTIFICATE_INFO )
  // ul1 - CtxtHandle*
  // ul2 - impersonation handle
  //
  SF_REQ_SET_CERTIFICATE_INFO = 5;
  //
  // Used to get an IIS property
  // as defined in SF_PROPERTY_IIS
  //
  // ul1 - Property ID
  //
  SF_REQ_GET_PROPERTY = 6;
  //
  // Used to normalize an URL
  //
  // pData - URL to normalize
  //
  SF_REQ_NORMALIZE_URL = 7;
  //
  // Disable Notifications
  //
  // ul1 - notifications to disable
  //
  SF_REQ_DISABLE_NOTIFICATIONS = 8;
type
  SF_REQ_TYPE = DWORD;
{$EXTERNALSYM SF_REQ_TYPE}
  TSF_REQ_TYPE = SF_REQ_TYPE;

const
  SF_PROPERTY_SSL_CTXT = 0;
  SF_PROPERTY_INSTANCE_NUM_ID = 1;
type
  SF_PROPERTY_IIS = DWORD;
  TSF_PROPERTY_IIS = SF_PROPERTY_IIS;

  //
  //  These values are returned by the filter entry point when a new request is
  //  received indicating their interest in this particular request
  //
const
  //
  //  The filter has handled the HTTP request.  The server should disconnect
  //  the session.
  //
  SF_STATUS_REQ_FINISHED = $8000000;
  //
  //  Same as SF_STATUS_FINISHED except the server should keep the TCP
  //  session open if the option was negotiated
  //
  SF_STATUS_REQ_FINISHED_KEEP_CONN = $8000001;
  //
  //  The next filter in the notification chain should be called
  //
  SF_STATUS_REQ_NEXT_NOTIFICATION = $8000002;
  //
  //  This filter handled the notification.  No other handles should be
  //  called for this particular notification type
  //
  SF_STATUS_REQ_HANDLED_NOTIFICATION = $8000003;
  //
  //  An error occurred.  The server should use GetLastError() and indicate
  //  the error to the client
  //
  SF_STATUS_REQ_ERROR = $8000004;
  //
  //  The filter is an opaque stream filter and we're negotiating the
  //  session parameters.  Only valid for raw read notification.
  //
  SF_STATUS_REQ_READ_NEXT = $8000005;
type
  SF_STATUS_TYPE = DWORD;
  TSF_STATUS_TYPE = SF_STATUS_TYPE;

  //
  //  pvNotification points to this structure for all request notification types
  //
type
  TGetServerVariable = function(var pfc {: THTTP_FILTER_CONTEXT}; lpszVariableName:
    LPSTR; lpvBuffer: LPVOID; var lpdwSize: DWORD): BOOL; stdcall;
  TAddResponseHeaders = function(var pfc {: THTTP_FILTER_CONTEXT}; lpszHeaders: LPSTR;
    dwReserved: DWORD): BOOL; stdcall;
  TWriteClient = function(var pfc {: THTTP_FILTER_CONTEXT}; Buffer: LPVOID; var
    lpdwBytes: DWORD; dwReserved: DWORD): BOOL; stdcall;
  TAllocMem = function(var pfc {: THTTP_FILTER_CONTEXT}; cbSize: DWORD; dwReserved:
    DWORD): Pointer; stdcall;
  TServerSupportFunction = function(var pfc {: THTTP_FILTER_CONTEXT}; sfReq:
    SF_REQ_TYPE; pData: PVOID; ul1: DWORD; ul2: DWORD): BOOL; stdcall;

  PHTTP_FILTER_CONTEXT = ^THTTP_FILTER_CONTEXT;
{$EXTERNALSYM PHTTP_FILTER_CONTEXT}
  _HTTP_FILTER_CONTEXT = packed record
    cbSize: DWORD;
    //
    //  This is the structure revision level.
    //
    Revision: DWORD;
    //
    //  Private context information for the server.
    //
    ServerContext: PVOID;
    ulReserved: DWORD;
    //
    //  TRUE if this request is coming over a secure port
    //
    fIsSecurePort: BOOL;
    //
    //  A context that can be used by the filter
    //
    pFilterContext: PVOID;
    //
    //  Server callbacks
    //
    GetServerVariable: TGetServerVariable;
    AddResponseHeaders: TAddResponseHeaders;
    WriteClient: TWriteClient;
    AllocMem: TAllocMem;
    ServerSupportFunction: TServerSupportFunction;
  end;
{$EXTERNALSYM _HTTP_FILTER_CONTEXT}
  THTTP_FILTER_CONTEXT = _HTTP_FILTER_CONTEXT;

  //
  //  This structure is the notification info for the read and send raw data
  //  notification types
  //
type
  PHTTP_FILTER_RAW_DATA = ^THTTP_FILTER_RAW_DATA;
{$EXTERNALSYM PHTTP_FILTER_RAW_DATA}
  _HTTP_FILTER_RAW_DATA = packed record
    //
    //  This is a pointer to the data for the filter to process.
    //
    pvInData: PVOID;
    cbInData: DWORD; // Number of valid data bytes
    cbInBuffer: DWORD; // Total size of buffer
    dwReserved: DWORD;
  end;
{$EXTERNALSYM _HTTP_FILTER_RAW_DATA}
  THTTP_FILTER_RAW_DATA = _HTTP_FILTER_RAW_DATA;

  //
  //  This structure is the notification info for when the server is about to
  //  process the client headers
  //
type
  TGetHeader = function(var pfc: _HTTP_FILTER_CONTEXT; lpszName: LPSTR; lpvBuffer:
    LPVOID; var lpdwSize: DWORD): BOOL; stdcall;
  TSetHeader = function(var pfc: _HTTP_FILTER_CONTEXT; lpszName: LPSTR; lpszValue:
    LPSTR): BOOL; stdcall;
  TAddHeader = function(var pfc: _HTTP_FILTER_CONTEXT; lpszName: LPSTR; lpszValue:
    LPSTR): BOOL; stdcall;

  PHTTP_FILTER_PREPROC_HEADERS = ^THTTP_FILTER_PREPROC_HEADERS;
{$EXTERNALSYM PHTTP_FILTER_PREPROC_HEADERS}
  _HTTP_FILTER_PREPROC_HEADERS = packed record
    //
    //  For SF_NOTIFY_PREPROC_HEADERS, retrieves the specified header value.
    //  Header names should include the trailing ':'.  The special values
    //  'method', 'url' and 'version' can be used to retrieve the individual
    //  portions of the request line
    //
    GetHeader: TGetHeader;
    //
    //  Replaces this header value to the specified value.  To delete a header,
    //  specified a value of '\0'.
    //
    SetHeader: TSetHeader;
    //
    //  Adds the specified header and value
    //
    AddHeader: TAddHeader;
    HttpStatus: DWORD; // New in 4.0, status for SEND_RESPONSE
    dwReserved: DWORD; // New in 4.0
  end;
{$EXTERNALSYM _HTTP_FILTER_PREPROC_HEADERS}
  THTTP_FILTER_PREPROC_HEADERS = _HTTP_FILTER_PREPROC_HEADERS;

type
  HTTP_FILTER_SEND_RESPONSE = _HTTP_FILTER_PREPROC_HEADERS;
{$EXTERNALSYM HTTP_FILTER_SEND_RESPONSE}
type
  PHTTP_FILTER_SEND_RESPONSE = ^_HTTP_FILTER_PREPROC_HEADERS;
{$EXTERNALSYM PHTTP_FILTER_SEND_RESPONSE}

  //
  //  Authentication information for this request.
  //
type
  PHTTP_FILTER_AUTHENT = ^THTTP_FILTER_AUTHENT;
{$EXTERNALSYM PHTTP_FILTER_AUTHENT}
  _HTTP_FILTER_AUTHENT = packed record
    //
    //  Pointer to username and password, empty strings for the anonymous user
    //
    //  Client's can overwrite these buffers which are guaranteed to be at
    //  least SF_MAX_USERNAME and SF_MAX_PASSWORD bytes large.
    //
    pszUser: PChar;
    cbUserBuff: DWORD;
    pszPassword: PChar;
    cbPasswordBuff: DWORD;
  end;
{$EXTERNALSYM _HTTP_FILTER_AUTHENT}
  THTTP_FILTER_AUTHENT = _HTTP_FILTER_AUTHENT;

  //
  //  Indicates the server is going to use the specific physical mapping for
  //  the specified URL.  Filters can modify the physical path in place.
  //
type
  PHTTP_FILTER_URL_MAP = ^THTTP_FILTER_URL_MAP;
{$EXTERNALSYM PHTTP_FILTER_URL_MAP}
  _HTTP_FILTER_URL_MAP = packed record
    pszURL: PChar;
    pszPhysicalPath: PChar;
    cbPathBuff: DWORD;
  end;
{$EXTERNALSYM _HTTP_FILTER_URL_MAP}
  THTTP_FILTER_URL_MAP = _HTTP_FILTER_URL_MAP;

  //
  //  Bitfield indicating the requested resource has been denied by the server due
  //  to a logon failure, an ACL on a resource, an ISAPI Filter or an
  //  ISAPI Application/CGI Application.
  //
  //  SF_DENIED_BY_CONFIG can appear with SF_DENIED_LOGON if the server
  //  configuration did not allow the user to logon.
  //
const
  SF_DENIED_LOGON = $00000001;
{$EXTERNALSYM SF_DENIED_LOGON}
  SF_DENIED_RESOURCE = $00000002;
{$EXTERNALSYM SF_DENIED_RESOURCE}
  SF_DENIED_FILTER = $00000004;
{$EXTERNALSYM SF_DENIED_FILTER}
  SF_DENIED_APPLICATION = $00000008;
{$EXTERNALSYM SF_DENIED_APPLICATION}

  SF_DENIED_BY_CONFIG = $00010000;
{$EXTERNALSYM SF_DENIED_BY_CONFIG}

type
  PHTTP_FILTER_ACCESS_DENIED = ^THTTP_FILTER_ACCESS_DENIED;
{$EXTERNALSYM PHTTP_FILTER_ACCESS_DENIED}
  _HTTP_FILTER_ACCESS_DENIED = packed record
    pszURL: PChar; // Requesting URL
    pszPhysicalPath: PChar; // Physical path of resource
    dwReason: DWORD; // Bitfield of SF_DENIED flags
  end;
{$EXTERNALSYM _HTTP_FILTER_ACCESS_DENIED}
  THTTP_FILTER_ACCESS_DENIED = _HTTP_FILTER_ACCESS_DENIED;

  //
  //  The log information about to be written to the server log file.  The
  //  string pointers can be replaced but the memory must remain valid until
  //  the next notification
  //
type
  PHTTP_FILTER_LOG = ^THTTP_FILTER_LOG;
{$EXTERNALSYM PHTTP_FILTER_LOG}
  _HTTP_FILTER_LOG = packed record
    pszClientHostName: PChar;
    pszClientUserName: PChar;
    pszServerName: PChar;
    pszOperation: PChar;
    pszTarget: PChar;
    pszParameters: PChar;
    dwHttpStatus: DWORD;
    dwWin32Status: DWORD;
    dwBytesSent: DWORD; // IIS 4.0 and later
    dwBytesRecvd: DWORD; // IIS 4.0 and later
    msTimeForProcessing: DWORD; // IIS 4.0 and later
  end;
{$EXTERNALSYM _HTTP_FILTER_LOG}
  THTTP_FILTER_LOG = _HTTP_FILTER_LOG;

  //
  //  Notification Flags
  //
  //  SF_NOTIFY_SECURE_PORT
  //  SF_NOTIFY_NONSECURE_PORT
  //
  //      Indicates whether the application wants to be notified for transactions
  //      that are happenning on the server port(s) that support data encryption
  //      (such as PCT and SSL), on only the non-secure port(s) or both.
  //
  //  SF_NOTIFY_READ_RAW_DATA
  //
  //      Applications are notified after the server reads a block of memory
  //      from the client but before the server does any processing on the
  //      block.  The data block may contain HTTP headers and entity data.
  //
  //
  //
const
  SF_NOTIFY_SECURE_PORT = $00000001;
{$EXTERNALSYM SF_NOTIFY_SECURE_PORT}
  SF_NOTIFY_NONSECURE_PORT = $00000002;
{$EXTERNALSYM SF_NOTIFY_NONSECURE_PORT}

  SF_NOTIFY_READ_RAW_DATA = $00008000;
{$EXTERNALSYM SF_NOTIFY_READ_RAW_DATA}
  SF_NOTIFY_PREPROC_HEADERS = $00004000;
{$EXTERNALSYM SF_NOTIFY_PREPROC_HEADERS}
  SF_NOTIFY_AUTHENTICATION = $00002000;
{$EXTERNALSYM SF_NOTIFY_AUTHENTICATION}
  SF_NOTIFY_URL_MAP = $00001000;
{$EXTERNALSYM SF_NOTIFY_URL_MAP}
  SF_NOTIFY_ACCESS_DENIED = $00000800;
{$EXTERNALSYM SF_NOTIFY_ACCESS_DENIED}
  SF_NOTIFY_SEND_RESPONSE = $00000040;
{$EXTERNALSYM SF_NOTIFY_SEND_RESPONSE}
  SF_NOTIFY_SEND_RAW_DATA = $00000400;
{$EXTERNALSYM SF_NOTIFY_SEND_RAW_DATA}
  SF_NOTIFY_LOG = $00000200;
{$EXTERNALSYM SF_NOTIFY_LOG}
  SF_NOTIFY_END_OF_REQUEST = $00000080;
{$EXTERNALSYM SF_NOTIFY_END_OF_REQUEST}
  SF_NOTIFY_END_OF_NET_SESSION = $00000100;
{$EXTERNALSYM SF_NOTIFY_END_OF_NET_SESSION}

  //
  //  Filter ordering flags
  //
  //  Filters will tend to be notified by their specified
  //  ordering.  For ties, notification order is determined by load order.
  //
  //  SF_NOTIFY_ORDER_HIGH - Authentication or data transformation filters
  //  SF_NOTIFY_ORDER_MEDIUM
  //  SF_NOTIFY_ORDER_LOW  - Logging filters that want the results of any other
  //                      filters might specify this order.
  //
const
  SF_NOTIFY_ORDER_HIGH = $00080000;
{$EXTERNALSYM SF_NOTIFY_ORDER_HIGH}
  SF_NOTIFY_ORDER_MEDIUM = $00040000;
{$EXTERNALSYM SF_NOTIFY_ORDER_MEDIUM}
  SF_NOTIFY_ORDER_LOW = $00020000;
{$EXTERNALSYM SF_NOTIFY_ORDER_LOW}
  SF_NOTIFY_ORDER_DEFAULT = SF_NOTIFY_ORDER_LOW;
{$EXTERNALSYM SF_NOTIFY_ORDER_DEFAULT}

  SF_NOTIFY_ORDER_MASK = (SF_NOTIFY_ORDER_HIGH or
    SF_NOTIFY_ORDER_MEDIUM or
    SF_NOTIFY_ORDER_LOW);
{$EXTERNALSYM SF_NOTIFY_ORDER_MASK}

  //
  //  Filter version information, passed to GetFilterVersion
  //
type
  PHTTP_FILTER_VERSION = ^THTTP_FILTER_VERSION;
{$EXTERNALSYM PHTTP_FILTER_VERSION}
  _HTTP_FILTER_VERSION = packed record
    //
    //  Version of the spec the server is using
    //
    dwServerFilterVersion: DWORD;
    //
    //  Fields specified by the client
    //
    dwFilterVersion: DWORD;
    lpszFilterDesc: array[0..SF_MAX_FILTER_DESC_LEN - 1] of Char;
    dwFlags: DWORD;
  end;
{$EXTERNALSYM _HTTP_FILTER_VERSION}
  THTTP_FILTER_VERSION = _HTTP_FILTER_VERSION;

  //
  //  A filter DLL's entry point looks like this.  The return code should be
  //  an SF_STATUS_TYPE
  //
  //  NotificationType - Type of notification
  //  pvNotification - Pointer to notification specific data
  //

  //    function GetFilterVersion(var pVer: THTTP_FILTER_VERSION): BOOL; stdcall;
  //    function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT; NotificationType: DWORD; pvNotification: Pointer): DWORD; stdcall;
  //    function TerminateFilter(dwFlags: DWORD): BOOL; stdcall;

implementation

end.

How to change colours in a 16 colour bitmap

Problem/Question/Abstract:

How to change colors in a 16 colour bitmap

Answer:

I found the solution which works best, although the final version will have the colors computed rather than hard coded. The bitmap I am using actually only uses the first 4 colors in the palette for shades of grey.

procedure TForm1.SetWallpaperPalette;
type
  RGBQUAD = packed record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
    rgbReserved: Byte;
  end;
var
  NewColors: array[1..4] of RGBQUAD;
begin
  FillChar(NewColors, SizeOf(NewColors), 0);
  with NewColors[1] do
  begin
    rgbBlue := 0;
    rgbGreen := $C6;
    rgbRed := $C6;
  end;
  with NewColors[2] do
  begin
    rgbBlue := 0;
    rgbGreen := $CE;
    rgbRed := $CE;
  end;
  with NewColors[3] do
  begin
    rgbBlue := 0;
    rgbGreen := $D6;
    rgbRed := $D6;
  end;
  with NewColors[4] do
  begin
    rgbBlue := 0;
    rgbGreen := $DE;
    rgbRed := $DE;
  end;
  if Assigned(SpeedBar1.Wallpaper.Bitmap) then
    SetDibColorTable(SpeedBar1.Wallpaper.Bitmap.Canvas.Handle, 0, 4, NewColors);
end;

Data Entry: Automagically Moving the Cursor

Problem/Question/Abstract:

How can I get the cursor to advance to the next form field after a field has been filled with the maximum number of characters?

Answer:

Hmm... sounds like a serial number or SSN entry thing to me. Whatever the case, the best way I've found to handle this is to use the OnChange method of the TEdit to determine the length of the text being entered at runtime. Then if the text has reached a specified length, call Self.ActiveControl to move to a specific control.

For example, I have an application that requires that the user enter a social security number separated by three fields. Instead of having the user press Tab to move from field to field, I trap the OnChange event handler to determine the length of the text and move to the next edit control if the text for the field in question reaches a certain size. Here's the code for my social security number entry:

procedure PatientForm.edSSNBegChange(Sender: TObject);
begin
  case TEdit(Sender).Tag of
    100: if Length(TEdit(Sender).Text) = 3 then
        ActiveControl := edSSNMid;
    101: if Length(TEdit(Sender).Text) = 2 then
        ActiveControl := edSSNEnd;
    102: if Length(TEdit(Sender).Text) = 4 then
        ActiveControl := Button1;
  end;
end;

On the form where this method lives, I have three edit boxes called edSSNBeg, edSSNMid and edSSNEnd to signify the first, middle, and end parts of a social security number. As you may know, a social security number is defined as a three-digit front plus a two-digit middle and a four-digit end. The code above captures this quite well.

Notice that I use the Tag property for the edit boxes. Each one has a specific tag value so the procedure can determine which edit box is currently active, because TEdit(Sender) doesn't tell you much. So by using the Tag property, I can save myself a lot of coding by using a case statement.

With respect to what decides whether the cursor should move, each case condition checks for the length of the current edit box's text using the Length property. If has reached the size specified, the cursor is moved to the next field.

Why does this work? OnChange fires after a change has been made to an edit box. So this scheme works because the change has already been made and you can readily measure the text size.

AVL-tree generic classes

Problem/Question/Abstract:

Balanced binary tree (AVL-tree) generic classes.

Answer:

AVLtrees unit implement fast insertion, replacing, deletion and search of item (complexity is O*log(N)).
It contains low level functions, low level class and user-friendly classes.
Most of functions are implemented on BASM (inline assembler).

You may use TStringKeyAVLtree, TIntegerKeyAVLtree classes directly or declare descedants from one of these.

Example for more complex way - declaring own classes:

type
  TMyItem = class;

  TMyCollection = class(TStringKeyAVLtree)
  protected
    function GetItems(AKey: string): TMyItem;
  public
    constructor Create;
    function Add(const AKey, ADescription: string): TMyItem;
    property Items[AKey: string]: TMyItem read GetItems;
  end;

  TMyItem = class(TStringKeyAVLtreeNode)
  protected
    FDescription: string;
  public
    property FileName: string read FKey;
      // for your convinience, FKey is defined in base class
    property Desciption: string read FDescription write FDescription;
  end;

constructor TMyCollection.Create;
begin
  inherited Create(TMyItem); // class of items
end;

function TMyCollection.Add(const AKey, ADescription: string): TMyItem;
begin
  Result := TMyItem(inherited Add(AKey));
  if Result = nil then
    raise Exception.Create('Item ''' + AKey + ''' already exists');
  Result.Description := ADescription;
end;

function GetItems(AKey: string): TMyItem;
begin
  Result := TMyItem(Find(AKey));
end;

See also little sample supplied with unit.

See Dr.D.E.Knuth "Art of Computer Programming" for more information about balanced trees.
For implementation of item deletion I use an article "An Iterative Algorithm for Deletion from AVL-Balanced Binary Trees" by Ben Pfaff , http://www.msu.edu/user/pfaffben/avl

AVLtrees unit (sources) is available on my homepage http://www.mtgroup.ru/~alexk/

Create a GUID at runtime

Problem/Question/Abstract:

Create a GUID at runtime

Answer:

You may need to create a GUID at runtime. One reason could be to simply have a unique number that identifies each workstation.By the way the last group of digits in the GUID generated on a computer is its network card number (if any is present).

Delphi does not have the needed definitions, here they are:

function CoCreateGuid(pGUID: TGUID): longint; external 'OLE32.DLL';

procedure TForm1.FormCreate(Sender: TObject);
var
  udtGUID: TGUID;
  lResult: longint;
begin
  lResult := CoCreateGuid(udtGUID);
  // see definition of TGUID in Delphi's online help
  // udtGUID.D4 = network card's number
end;

How to create a print preview

Problem/Question/Abstract:

I am trying to put together a simple print preview program that can be used by other programs. I am using the panel component as my printing cavas and I am having troubles equating the screen and page ratios. Does anyone have any ideas on how I could simplify this task or point me in the direction of a good book or give some example code?

Answer:

unit printpreview;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    PreviewPaintbox: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    LeftMarginEdit: TEdit;
    TopMarginEdit: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    RightMarginEdit: TEdit;
    Label5: TLabel;
    BottomMarginEdit: TEdit;
    ApplyMarginsButton: TButton;
    OrientationRGroup: TRadioGroup;
    Label6: TLabel;
    ZoomEdit: TEdit;
    ZoomUpDown: TUpDown;
    procedure LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure PreviewPaintboxPaint(Sender: TObject);
    procedure ApplyMarginsButtonClick(Sender: TObject);
  private
    { Private declarations }
    PreviewText: string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses printers;

{$R *.DFM}

procedure TForm1.LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['0'..'9', #9, DecimalSeparator]) then
    Key := #0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  S: string;

  procedure loadpreviewtext;
  var
    sl: TStringList;
  begin
    sl := TStringList.Create;
    try
      sl.Loadfromfile(Extractfilepath(application.exename) + 'printpreview.pas');
      PreviewText := sl.Text;
    finally
      sl.free
    end;
  end;

begin
  {Initialize the margin edits with a margin of 0.75 inch}
  S := FormatFloat('0.00', 0.75);
  LeftMarginEdit.Text := S;
  TopMarginEdit.Text := S;
  RightMarginEdit.Text := S;
  BottomMarginEdit.Text := S;
  {Initialize the orientation radio group}
  if Printer.Orientation = poPortrait then
    OrientationRGroup.ItemIndex := 0
  else
    OrientationRGroup.ItemIndex := 1;
  {load test text for display}
  LoadPreviewtext;
end;

procedure TForm1.PreviewPaintboxPaint(Sender: TObject);
var
  pagewidth, pageheight: Double; {printer page dimension in inch}
  printerResX, printerResY: Integer; {printer resolution in dots/inch}
  minmarginX, minmarginY: Double; {nonprintable margin in inch}
  outputarea: TRect; {print area in 1/1000 inches}
  scale: Double; {conversion factor, pixels per 1/1000 inch}

  procedure InitPrintSettings;
    function GetMargin(S: string; inX: Boolean): Double;
    begin
      Result := StrToFloat(S);
      if InX then
      begin
        if Result < minmarginX then
          Result := minmarginX;
      end
      else
      begin
        if Result < minmarginY then
          Result := minmarginY;
      end;
    end;
  begin
    printerResX := GetDeviceCaps(printer.handle, LOGPIXELSX);
    printerResY := GetDeviceCaps(printer.handle, LOGPIXELSY);
    pagewidth := GetDeviceCaps(printer.handle, PHYSICALWIDTH) / printerResX;
    pageheight := GetDeviceCaps(printer.handle, PHYSICALHEIGHT) / printerResY;
    minmarginX := GetDeviceCaps(printer.handle, PHYSICALOFFSETX) / printerResX;
    minmarginY := GetDeviceCaps(printer.handle, PHYSICALOFFSETY) / printerResY;
    outputarea.Left := Round(GetMargin(LeftMarginEdit.Text, true) * 1000);
    outputarea.Top := Round(GetMargin(TopMarginEdit.Text, false) * 1000);
    outputarea.Right := Round((pagewidth - GetMargin(RightMarginEdit.Text, true)) *
      1000);
    outputarea.Bottom := Round((pageheight - GetMargin(BottomMarginEdit.Text, false))
      * 1000);
  end;

  procedure ScaleCanvas(Canvas: TCanvas; widthavail, heightavail: Integer);
  var
    needpixelswidth, needpixelsheight: Integer;
    {dimensions of preview at current zoom factor in pixels}
    orgpixels: TPoint;
    {origin of preview in pixels}
  begin
    {set up a coordinate system for the canvas that uses 1/1000 inch as unit,
    honors the zoom factor and maintains the MM_TEXT orientation of the
    coordinate axis (origin in top left corner, positive Y axis points down}
    scale := Screen.PixelsPerInch / 1000;
    {Apply zoom factor}
    scale := scale * StrToInt(Zoomedit.text) / 100;
    {figure out size of preview}
    needpixelswidth := Round(pagewidth * 1000 * scale);
    needpixelsheight := Round(pageheight * 1000 * scale);
    if needpixelswidth >= widthavail then
      orgpixels.X := 0
    else
      orgpixels.X := (widthavail - needpixelswidth) div 2;
    if needpixelsheight >= heightavail then
      orgpixels.Y := 0
    else
      orgpixels.Y := (heightavail - needpixelsheight) div 2;
    {change mapping mode to MM_ISOTROPIC}
    SetMapMode(canvas.handle, MM_ISOTROPIC);
    {move viewport origin to orgpixels}
    SetViewportOrgEx(canvas.handle, orgpixels.x, orgpixels.y, nil);
    {scale the window}
    SetViewportExtEx(canvas.handle, Round(1000 * scale), Round(1000 * scale), nil);
    SetWindowExtEx(canvas.handle, 1000, 1000, nil);
  end;

begin
  if OrientationRGroup.ItemIndex = 0 then
    Printer.Orientation := poPortrait
  else
    Printer.Orientation := poLandscape;
  InitPrintsettings;
  with Sender as TPaintBox do
  begin
    ScaleCanvas(Canvas, ClientWidth, ClientHeight);
    {specify font height in 1/1000 inch}
    Canvas.Font.Height := Round(font.height / font.pixelsperinch * 1000);
    {paint page white}
    Canvas.Brush.Color := clWindow;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(Rect(0, 0, Round(pagewidth * 1000), Round(pageheight * 1000)));
    {draw the text}
    DrawText(canvas.handle, PChar(PreviewText), Length(PreviewText),
      outputarea, DT_WORDBREAK or DT_LEFT);
    {Draw thin gray lines to mark borders}
    Canvas.Pen.Color := clGray;
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 10;
    with Canvas do
    begin
      MoveTo(outputarea.left - 100, outputarea.top);
      LineTo(outputarea.right + 100, outputarea.top);
      MoveTo(outputarea.left - 100, outputarea.bottom);
      LineTo(outputarea.right + 100, outputarea.bottom);
      MoveTo(outputarea.left, outputarea.top - 100);
      LineTo(outputarea.left, outputarea.bottom + 100);
      MoveTo(outputarea.right, outputarea.top - 100);
      LineTo(outputarea.right, outputarea.bottom + 100);
    end;
  end;
end;

procedure TForm1.ApplyMarginsButtonClick(Sender: TObject);
begin
  PreviewPaintbox.Invalidate;
end;

end.


---------------------------------------------------------------------------------
{
object Form1: TForm1
  Left = 192
  Top = 128
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clWindowText
  Font.Height = -15
  Font.Name = 'Arial'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 120
  TextHeight = 17
  object Panel1: TPanel
    Left = 503
    Top = 0
    Width = 185
    Height = 453
    Align = alRight
    TabOrder = 0
    object Label1: TLabel
      Left = 8
      Top = 8
      Width = 92
      Height = 17
      Caption = 'Margins (inch)'
    end
    object Label2: TLabel
      Left = 8
      Top = 45
      Width = 24
      Height = 17
      Caption = 'Left'
    end
    object Label3: TLabel
      Left = 8
      Top = 77
      Width = 25
      Height = 17
      Caption = 'Top'
    end
    object Label4: TLabel
      Left = 8
      Top = 109
      Width = 34
      Height = 17
      Caption = 'Right'
    end
    object Label5: TLabel
      Left = 8
      Top = 141
      Width = 47
      Height = 17
      Caption = 'Bottom'
    end
    object Label6: TLabel
      Left = 8
      Top = 261
      Width = 64
      Height = 17
      Caption = 'Zoom (%)'
    end
    object LeftMarginEdit: TEdit
      Left = 60
      Top = 40
      Width = 100
      Height = 25
      TabOrder = 0
      OnKeyPress = LeftMarginEditKeyPress
    end
    object TopMarginEdit: TEdit
      Left = 60
      Top = 72
      Width = 100
      Height = 25
      TabOrder = 1
      OnKeyPress = LeftMarginEditKeyPress
    end
    object RightMarginEdit: TEdit
      Left = 60
      Top = 104
      Width = 100
      Height = 25
      TabOrder = 2
      OnKeyPress = LeftMarginEditKeyPress
    end
    object BottomMarginEdit: TEdit
      Left = 60
      Top = 136
      Width = 100
      Height = 25
      TabOrder = 3
      OnKeyPress = LeftMarginEditKeyPress
    end
    object ApplyMarginsButton: TButton
      Left = 24
      Top = 304
      Width = 137
      Height = 25
      Caption = 'Apply'
      TabOrder = 4
      OnClick = ApplyMarginsButtonClick
    end
    object OrientationRGroup: TRadioGroup
      Left = 8
      Top = 176
      Width = 161
      Height = 65
      Caption = 'Orientation'
      Items.Strings = (
        'Portrait'
        'Landscape')
      TabOrder = 5
    end
    object ZoomEdit: TEdit
      Left = 80
      Top = 256
      Width = 40
      Height = 25
      TabOrder = 6
      Text = '50'
    end
    object ZoomUpDown: TUpDown
      Left = 120
      Top = 256
      Width = 17
      Height = 25
      Associate = ZoomEdit
      Min = 0
      Increment = 10
      Position = 50
      TabOrder = 7
      Wrap = False
    end
  end
  object Panel2: TPanel
    Left = 0
    Top = 0
    Width = 503
    Height = 453
    Align = alClient
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -17
    Font.Name = 'Times New Roman'
    Font.Style = []
    ParentFont = False
    TabOrder = 1
    object PreviewPaintbox: TPaintBox
      Left = 1
      Top = 1
      Width = 501
      Height = 451
      Align = alClient
      OnPaint = PreviewPaintboxPaint
    end
  end
end
}
---------------------------------------------------------------------------------

How to change the color of the selection in a TCheckListBox

Problem/Question/Abstract:

How to change the color of the selection in a TCheckListBox

Answer:

If you want to change the color of the selection so that it's always the Color property, this code will work:

procedure TForm1.CheckListBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  with Control as TCheckListBox do
  begin
    { Use the default colors regardless of selection status }
    Canvas.Font.Color := Font.Color;
    Canvas.Brush.Color := Color;
    { Erase everything there at the moment }
    Canvas.FillRect(Rect);
    { Draw the text }
    Canvas.TextOut(Rect.Left + 2, Rect.Top, Items[Index]);
  end;
end;

How to check if the caret position in a TMemo is between two HTML tags

Problem/Question/Abstract:

I need a string procedure that checks whether the caret position is between the tags '<>' , and if this is true, the contents of the tag are placed in a string for further processing.

Answer:

Something like this:

function FindTextBetweenTags(const S: string; caretpos: Integer): string;
var
  nStart, nEnd: Integer;
begin
  Result := EmptyStr;
  {caretpos is 0-based, string indices are 1-based}
  Inc(caretpos);
  {move backwards from caretpos util we find a '<'}
  nstart := caretpos;
  while ((nstart > 0) and (S[nstart]) <> '<') do
    Dec(nstart);
  if nstart = 0 then
    Exit;
  {move to first char after '<'}
  Inc(nstart);
  if S[nstart] = '>' then
    Exit; {empty tag}
  {move forward until we find a '>'}
  nend := nstart;
  while (nend <= Length(S)) and (S[nend] <> '>') do
    Inc(nend);
  if (nend > Length(S)) or (nend <= caretpos) then
    Exit;
  Result := Copy(S, nstart, nend - nstart);
end;

You would call it like

tagstring := FindtextBetweentags(memo1.text, memo1.selstart);

How to execute a method by name

Problem/Question/Abstract:

I have a reference to a TMethod (with its Data and Code pointers) and would like to execute the associated method. Does anyone know how I can do this?

Answer:

Here is an example that executes a method by name. Note that the method to be called (in the example that is SomeMethod) must be declared as published, otherwise MethodAddress wil return nil.


{ ... }
type
  PYourMethod = ^TYourMethod;
  TYourMethod = procedure(S: string) of object;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  ExecMethodByName('SomeMethod');
end;

procedure TMainForm.ExecMethodByName(AName: string);
var
  PAddr: PYourMethod;
  M: TMethod;
begin
  PAddr := MethodAddress(AName);
  if PAddr <> nil then
  begin
    M.Code := PAddr;
    M.Data := Self;
    TYourMethod(M)('hello');
  end;
end;

procedure TMainForm.SomeMethod(S: string);
begin
  ShowMessage(S);
end;

Add items to the Windows Explorer right-click menu

Problem/Question/Abstract:

How do I add some items to Explorer's right-click menu, which appears when the user right-clicks on a certain file type?

Answer:

procedure add_context_menu;
type
  extns = (wav, png, bmp, jpg);
const
  ext_names: array[extns] of string = ('.wav', '.png', '.bmp', '.jpg');
var
  ext: extns;
  reg: TRegistry;
  name: string;
  command: string;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CLASSES_ROOT;
  {Build the command string we want to store}
  command := '"' + Application.ExeName + '" "%1"';
  {Loop over extensions we can handle}
  for ext := wav to jpg do
  begin
    {See if this extension is already known in HKEY_CLASSES_ROOT}
    if reg.OpenKeyReadOnly('\' + ext_names[ext]) then
    begin
      name := reg.ReadString(''); {Get the name of this type}
      if name <> '' then
        {If not blank, open this type's shell key, but don't create it}
        if reg.OpenKey('\' + name + '\shell', False) then
          {Try to create a new key called "APTprocess". Note that for Delphi5 we
          need to set the access explicitly}
          reg.Access := KEY_READ or KEY_WRITE;
      if reg.OpenKey('APTprocess', True) then
      begin
        {The default value will be displayed in the context menu}
        reg.WriteString('', '&APT process');
        {So now open the command key, creating it if required}
        reg.Access := KEY_READ or KEY_WRITE;
        if reg.OpenKey('command', True) then
          {and write the command string as the default value}
          reg.WriteString('', command);
      end;
    end;
  end;
  reg.Free;
end;

How to delete a line from a TRichEdit

Problem/Question/Abstract:

How do you delete a line from a TRichEdit at the current cursor point?

Answer:

uses
  richedit; {for EM_EXLINEFROMCHAR}

var
  lineindex: Integer;
  { ... }

with richedit1 do
begin
  lineindex := perform(EM_EXLINEFROMCHAR, 0, SelStart);
  SelStart := perform(EM_LINEINDEX, lineindex, 0);
  SelLength := perform(EM_LINEINDEX, lineindex + 1, 0) - SelStart;
  SelText := '';
end;

Create a predefined TTabSheet at design time and call it at runtime

Problem/Question/Abstract:

I would like to create a predefinied TTabSheet (e.g. four edit boxes on the TTabsheet) at design time. And at runtime, I would like to create the predefined TTabSheet as many according to my own need. Basically my question here is how to create the TTabSheet object with four editboxes on it, and then call the tabsheet at runtime.

Answer:

You can do this using streaming. Here is a little example project. The two key points are:

the components on the template tabsheet need to be owned by the tabsheet, not the form. The formCreate method takes care of this.
all control classes used on the tabsheet need to be registered. The RegisterClasses call in the initialisation section takes care of that.


unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    CloneButton: TButton;
    Memo1: TMemo;
    procedure CloneButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    procedure ShowStream(ms: TMemoryStream);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ShowStream(ms: TMemoryStream);
var
  ts: TStringstream;
begin
  ts := TStringstream.Create(EmptyStr);
  try
    ObjectBinaryToText(ms, ts);
    ms.Position := 0;
    memo1.text := ts.DataString;
  finally
    ts.free
  end;
end;

procedure TForm1.CloneButtonClick(Sender: TObject);
var
  ms: TMemoryStream;
  sheet: TTabSheet;
  S: string;
begin
  ms := TMemoryStream.Create;
  try
    ms.WriteComponent(Tabsheet1);
    ms.Position := 0;
    ShowStream(ms);
    sheet := ms.ReadComponent(nil) as TTabsheet;
    sheet.Pagecontrol := pagecontrol1;
    sheet.Caption := format('Tabsheet%d', [pagecontrol1.pagecount]);
  finally
    ms.free
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  c: TControl;
begin
  {make the template tabsheet the owner of all controls on it}
  for i := 0 to Tabsheet1.Controlcount - 1 do
  begin
    c := Tabsheet1.Controls[i];
    Self.RemoveComponent(c);
    Tabsheet1.InsertComponent(c);
  end;
end;

initialization
  RegisterClasses([TTabSheet, TEdit]);
end.

Syntax Highlighted Source Code Export to HTML or RTF

Problem/Question/Abstract:

It was asked for an easy way to export all types of source code to HTML.  The Open Source SynEdit components provide this functionality.  Using those I created a simple utility to allow for command line driven exporting of most source code to both HTML and RTF formats.

Answer:

{
Syntax Highlighted Source Code Export to HTML or RTF
Written and (c) 2002 by Jim McKeeth jim@bsdg.org

Pascal, Borland Dfm, HTML, CSS, HC11, ADSP21xx, AWK, Baan, Cache,
CAC, CPM, Fortran, Foxpro, Galaxy, Dml, General, GWScript, HP48, INI, Inno, Java, JScript, Kix, Modelica, M3, VBScript, Bat, Perl, PHP, Progress, SDD, SQL, SML, TclTk, VB, Asm, Cpp, Python to HTML or RTF with end user customization.
\Uses the open source SynEdit component suite.

It was asked for an easy way to export all types of source code to HTML.  The Open Source SynEdit components provide this functionality.  Using those I created a simple utility to allow for command line driven exporting of most source code to both HTML and RTF formats.

Note, this was written in Delphi 6 but should work with C++ Builder 3 or better, Delphi 3 or better or Kylix with only minimal changes.

First rule when developing with Delphi: No need to reinvent the wheel.  Sure, I could have come up with my own routines to format source code to HTML, but why when SynEdit is freely available and works great.  Before you start, you will need to download and install the SynEdit suite of components from
http://synedit.sourceforge.net/ .

There are three main parts to this: Parse the command-line parameters;  Verify the parameters;  Format the source code.

Here is the unit header along with a list of internal supported highlighters.
}
unit ExportUnit;

{ Internal supported highlighter keywords
Pas
Dfm
HTML
Css
HC11
ADSP21xx
AWK
Baan
Cache
CAC
CPM
Fortran
Foxpro
Galaxy
Dml
General
GWScript
HP48
Ini
Inno
Java
JScript
Kix
Modelica
M3
VBScript
Bat
Perl
PHP
Progress
SDD
SQL
SML
TclTk
VB
Asm
Cpp
Python
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Dialogs, Controls, Forms,
    SynHighlighterAsm, SynHighlighterVB, SynHighlighterTclTk, SynHighlighterSml,
    SynHighlighterSQL, SynHighlighterSDD, SynHighlighterPython, SynHighlighterProgress,
    SynHighlighterPHP, SynHighlighterPerl, SynHighlighterBat, SynHighlighterVBScript,
    SynHighlighterM3, SynHighlighterModelica, SynHighlighterKix, SynHighlighterJScript,
    SynHighlighterJava, SynHighlighterInno, SynHighlighterIni, SynHighlighterHtml,
    SynHighlighterHP48, SynHighlighterGWS, SynHighlighterGeneral, SynHighlighterDml,
    SynHighlighterGalaxy, SynHighlighterFoxpro, SynHighlighterFortran,
    SynHighlighterDfm, SynHighlighterCPM, SynHighlighterCss, SynHighlighterCAC,
    SynHighlighterCache, SynHighlighterCpp, SynHighlighterBaan, SynHighlighterAWK,
    SynHighlighterADSP21xx, SynHighlighterHC11, SynEditHighlighter, SynHighlighterPas,
    SynExportRTF, SynEditExport, SynExportHTML, SynHighlighterMulti, StdCtrls, ExtCtrls;

{
First we need to setup the form.  I simple have a large TMemo called memoLog that is set to client justified.  Now we add the SynEdit components we need.
Simply add one TsynExporterHTML and one TsynExporterRTF from the SynEdit tab.
Rename them ExporterHTML and ExporterRTF respeively.  Now add the
TsynHighlightManager.  When you add this component it brings up a dialog allowing you to choose which Highlighters to add.  Simple click "Select All" and "Ok" to add one of each.  Leave the names as the defaults.
}

type
  TformSynEdit = class(TForm)
    ExporterHTML: TSynExporterHTML;
    ExporterRTF: TSynExporterRTF;
    memoLog: TMemo;
    SynHC11Syn1: TSynHC11Syn;
    SynADSP21xxSyn1: TSynADSP21xxSyn;
    SynAWKSyn1: TSynAWKSyn;
    SynBaanSyn1: TSynBaanSyn;
    SynCppSyn1: TSynCppSyn;
    SynCacheSyn1: TSynCacheSyn;
    SynCACSyn1: TSynCACSyn;
    SynCssSyn1: TSynCssSyn;
    SynCPMSyn1: TSynCPMSyn;
    SynDfmSyn1: TSynDfmSyn;
    SynFortranSyn1: TSynFortranSyn;
    SynFoxproSyn1: TSynFoxproSyn;
    SynGalaxySyn1: TSynGalaxySyn;
    SynDmlSyn1: TSynDmlSyn;
    SynGeneralSyn1: TSynGeneralSyn;
    SynGWScriptSyn1: TSynGWScriptSyn;
    SynHP48Syn1: TSynHP48Syn;
    SynHTMLSyn1: TSynHTMLSyn;
    SynIniSyn1: TSynIniSyn;
    SynInnoSyn1: TSynInnoSyn;
    SynJavaSyn1: TSynJavaSyn;
    SynJScriptSyn1: TSynJScriptSyn;
    SynKixSyn1: TSynKixSyn;
    SynModelicaSyn1: TSynModelicaSyn;
    SynM3Syn1: TSynM3Syn;
    SynVBScriptSyn1: TSynVBScriptSyn;
    SynBatSyn1: TSynBatSyn;
    SynPasSyn1: TSynPasSyn;
    SynPerlSyn1: TSynPerlSyn;
    SynPHPSyn1: TSynPHPSyn;
    SynProgressSyn1: TSynProgressSyn;
    SynPythonSyn1: TSynPythonSyn;
    SynSDDSyn1: TSynSDDSyn;
    SynSQLSyn1: TSynSQLSyn;
    SynSMLSyn1: TSynSMLSyn;
    SynTclTkSyn1: TSynTclTkSyn;
    SynVBSyn1: TSynVBSyn;
    SynAsmSyn1: TSynAsmSyn;
    procedure PerformHighlight(const sInFile, sOutFile: string;
      sceHighlighter: TSynCustomExporter);
    procedure VerifyParameters(const sInFile: string; sOutFile: string = '';
      sHighlighter: string = '');
    procedure ParseParameters;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Log(s: string);

  end;

var
  formSynEdit: TformSynEdit;

  {These are some simple string parsing rontines that wrote a long time ago and
  use in many of my new programs.}
function pright(const s, divisor: string): string;
function pleft(const s, divisor: string): string;
function ReverseStr(const s: string): string;
function ValueOf(const S: string): string;
function NameOf(const S: string): string;

implementation

{$R *.dfm}

{ I have a method for adding lines to he memo called log.
I use the ~ or character #126 for line breaks.}

procedure TformSynEdit.Log(s: string);
begin
  memoLog.Lines.Add(StringReplace(s, #126, #13#10, [rfReplaceAll]));
end;

{Returns the portion of the string left of the divisor}

function pleft(const s, divisor: string): string;
begin
  if pos(divisor, s) > 0 then
    result := copy(s, 1, pos(divisor, s) - 1)
  else
    result := s;
end;

{Returns string in reverse}

function ReverseStr(const s: string): string;
var
  ctr: Integer;
  s2: string;
begin
  s2 := s;
  for ctr := 1 to length(s) do
    s2[length(s) - ctr + 1] := s[ctr];
  result := s2;
end;

{Returns the portion of the string right of the divisor}

function pright(const s, divisor: string): string;
var
  rs: string;
begin
  rs := ReverseStr(s);
  result := ReverseStr(PLeft(rs, reverseStr(divisor)));
end;

{Returns the portion of the string right of the '='}

function ValueOf(const s: string): string;
begin
  result := pright(s, pleft(s, '=') + '=');
end;

{Returns the portion of the string left of the '='}

function NameOf(const s: string): string;
begin
  result := pleft(s, '=');
end;

{This is called from the VerifyParamters routine to find a matching highlighter based on the extension of the input file.  It works by seperating each extension of the filter as a item in a string list and then look to see if the specified extension is in the list.}

function FilterMatch(sExt, sFilter: string): Boolean;
var
  slExts: TStringList;
begin
  slExts := TStringList.Create;
  try
    slExts.Delimiter := ';';
    slExts.DelimitedText := pright(sFilter, '|');
    Result := slExts.indexof('*' + sExt) > -1;
  finally
    slExts.Free;
  end;
end;

{This routine is not currently used, but was used to save some template highlighters to disk.}
{
function ComponentToFile(Component: TComponent; const sFileName: string)
           : boolean;
var
  BinStream: TMemoryStream;
  FileStream: TFileStream;
begin
  BinStream := TMemoryStream.Create;
  try
    FileStream := TFileStream.Create(sFileName, fmCreate or fmShareExclusive);
    try
      BinStream.WriteComponent(Component);  // write the component to the stream
      BinStream.Seek(0, soFromBeginning);  // seek to the origin of the stream
      // convert the binary representation of the component to easily editable
      // text format and save it to a FileStream
      ObjectBinaryToText(BinStream, FileStream);
      Result:= True;
    finally
      FileStream.Free;
    end;
  finally
    BinStream.Free
  end;
end;
}

{This is the routine used to load the external highlighter as a component.}

function FileToComponent(sFileName: string): TComponent;
var
  FileStream: TFileStream;
  BinStream: TMemoryStream;
begin
  FileStream := TFileStream.Create(sFileName, fmOpenRead or fmShareExclusive);
  try
    BinStream := TMemoryStream.Create;
    try
      // convert the user editable text format to binary
      ObjectTextToBinary(FileStream, BinStream);
      BinStream.Seek(0, soFromBeginning); // seek to the origin of the stream
      // create the component from the stream
      Result := BinStream.ReadComponent(nil);
    finally
      BinStream.Free;
    end;
  finally
    FileStream.Free;
  end;
end;

{-- Parsing command-line parameters --

We accept up to three parameters, but only require one.
Here is the usage statement:

Command-line usage:
> SrcFormat IN=(Input File) [OUT=(Output File)] [HIGHLIGHTER=(Highligher Name)]

Where
> IN=(Input File) is the required input file.
  Example: 'In="C:\My Documents\Source\SrcFormat.dpr"'
> OUT=(Output File) is the optional output file.
  Format is based on extension HTML or RTF.
  Default is same file name and path with an additional '.HTM'.
  Example: 'Out=C:\Source.RTF'
> HIGHLIGHTER=(Highlighter Name) is the optional Highlighter to use.
  If not provided then guessed based on extension.
  Can also be the file name of a saved Highlighter.
  Example: 'Highlighter=Pas'
  Example: 'Highlighter="C:\My Documents\Highlighters\MyPascal.hi"'

We only require that they specify the input file, and in fact if they only
specify a single parameter, even without the "IN=" prefix, then we assume it is
the input file.  We attempt an educated guess on the rest.

Here is the code we can use to parse the command-line parameters:}

procedure TformSynEdit.ParseParameters;
var
  sInFile, sOutFile, sHighlighter: string;
  iCtr: Integer;
begin
  if (ParamCount = 1) and (FileExists(ParamStr(1))) then
    sInFile := ParamStr(1) // if only one then it is the input file
  else if ParamCount > 0 then
    for iCtr := 1 to ParamCount do // spin though the parameters
    begin
      if CompareText(NameOf(ParamStr(iCtr)), 'IN') = 0 then
        sInFile := ValueOf(ParamStr(iCtr)) // Input file
      else if CompareText(NameOf(ParamStr(iCtr)), 'OUT') = 0 then
        sOutFile := ValueOf(ParamStr(iCtr)) // Output file
      else if CompareText(NameOf(ParamStr(iCtr)), 'HIGHLIGHTER') = 0 then
        sHighlighter := ValueOf(ParamStr(iCtr)) // highlighter
    end
  else
  begin // explain the usage
    Log('Command-line usage: '#126 +
      '> SrcFormat IN=(Input File) [OUT=(Output File)] ' +
      '[HIGHLIGHTER=(Highligher Name)]' + #126 + #126 +
      'Where' + #126 +
      '> IN=(Input File) is the required input file.  ' + #126 +
      '  Example: ''In="C:\My Documents\Source\SrcFormat.dpr"''' + #126 +
      '> OUT=(Output File) is the optional output file.  ' + #126 +
      '  Format is based on extension HTML or RTF.' + #126 +
      '  Default is same file name and path with an additional ''.HTM''.'
      + #126 +
      '  Example: ''Out=C:\Source.RTF''' + #126 +
      '> HIGHLIGHTER=(Highlighter Name) is the Highlighter to use.'
      + #126 +
      '  If not provided then guessed based on extension.  ' + #126 +
      '  Can also be the file name of a saved Highlighter.' + #126 +
      '  Example: ''Highlighter=Pas''' + #126 +
      '  Example: ''Highlighter="C:\My Documents\SrcExport\MyPascal.hi"'''
      );
    Exit;
  end;

  // Finally we pass all the variables to the VerifyParameters routine.
  VerifyParameters(sInFile, sOutFile, sHighlighter);
end;

{You could actually call this routine from a GUI interface as well as the
ParseParameters method, but I will let you add that functionality.  I'll step
you through each section of this routine.}

procedure TformSynEdit.VerifyParameters(const sInFile: string; sOutFile,
  sHighlighter: string);
var
  sInExt, sOutExt: string;
  myExporter: TSynCustomExporter;
  iCtr: Integer;
begin
  {First verify that the input file does exist.  We cannot format something that
  has not been saved to disk yet (although that would make a great Delphi Expert!)
  We simply add a log line and exit if the file is non-existent.}
  if not FileExists(sInFile) then
  begin
    Log('The input file "' + sInFile + '" does not exist');
    Exit;
  end;

  {If they did not specify an output file then we append an 'HTM' extension.}
  if sOutFile = '' then
    sOutFile := sInFile + '.HTM';

  {Make sure the output file does not exist.}
  if FileExists(sOutFile) then
  try
    DeleteFile(sOutFile);
  except
    log('Output file exists and cannot be deleted');
    Exit;
  end;

  {Make sure we can create the output file.}
  try
    // Make sure we can create the path
    ForceDirectories(ExtractFilePath(sOutFile));
    // Create and close a test file
    FileClose(FileCreate(sOutFile));
  except
    log('Cannot create output file!');
    Exit;
  end;

  {Extract the extensions of the files for guessing the highlighter and format.}
  sInExt := UpperCase(ExtractFileExt(sInFile));
  sOutExt := UpperCase(ExtractFileExt(sOutFile));

  {Now we guess the export format.
  If it is not an .RTF extension then we assume HTML.}
  if sOutExt = '.RTF' then
  begin
    log('Exporting to RTF');
    myExporter := ExporterRTF;
  end
  else
  begin
    log('Exporting to HTML');
    myExporter := ExporterHTML;
  end;

  {Now we guess the highlighter.  To do this we will spin through all the
  DefaultFilter properties of the highlighters we included on the form.  Since we
  stop on the first match, you may want to change the creation order (by right
  clicking on the form) to put your most common highlighters first.  }
  myExporter.Highlighter := nil;

  // only do with if no highlighter was specified at the command-line
  if sHighlighter = '' then
  begin
    for iCtr := 0 to pred(ComponentCount) do // go through all the componets
      // only look at highlighters
      if Components[iCtr] is TSynCustomHighlighter then
        // use the filter match method to see if the extension matches the filter
        if FilterMatch(sInExt,
          (Components[iCtr] as TSynCustomHighlighter).DefaultFilter) then
        begin
          // Set the name of the highlighter as the meaningful part of the
          // component name.
          sHighlighter := Copy(Components[iCtr].Name, 4,
            Length(Components[iCtr].Name) - 7);
          // set the actual highlighter property of the exporter
          myExporter.Highlighter := Components[iCtr] as TSynCustomHighlighter;
          // no more looping, we have what we want.
          Break;
        end;
  end;

  if sHighlighter = '' then
  begin // we didn't find an internal one, but we might find an external one.
    log('No highlighter was found for the extension ' + sInExt);
  end;

  // if they specified a highlighter at the command line find it now.
  if (myExporter.Highlighter = nil) and (sHighlighter <> '') then
    for iCtr := 0 to pred(ComponentCount) do
      if Components[iCtr] is TSynCustomHighlighter then
        if CompareText(Components[iCtr].Name, 'Syn' + sHighlighter + 'Syn1') = 0 then
        begin
          myExporter.Highlighter := Components[iCtr] as TSynCustomHighlighter;
          Break;
        end;

  // we still don't have a highlighter but one was specified
  if (myExporter.Highlighter = nil) and (sHighlighter <> '') then
  begin
    log('No internal highlighter named ''' + sHighlighter + ''' found!');
    // but there is a file with the same name as the specified highlighter,
    // maybe it is an external highlighter!
    if FileExists(sHighlighter) then
    begin
      log('Loading highlighter: ' + sHighlighter);
      // before you can load a component you need to register the class.
      RegisterClasses([TSynExporterHTML, TSynExporterRTF, TSynPasSyn,
        TSynDfmSyn, TSynHTMLSyn, TSynCssSyn, TSynHC11Syn, TSynADSP21xxSyn,
          TSynAWKSyn, TSynBaanSyn, TSynCacheSyn, TSynCACSyn, TSynCPMSyn,
          TSynFortranSyn, TSynFoxproSyn, TSynGalaxySyn, TSynDmlSyn,
          TSynGeneralSyn, TSynGWScriptSyn, TSynHP48Syn, TSynIniSyn, TSynInnoSyn,
          TSynJavaSyn, TSynJScriptSyn, TSynKixSyn, TSynModelicaSyn, TSynM3Syn,
          TSynVBScriptSyn, TSynBatSyn, TSynPerlSyn, TSynPHPSyn, TSynProgressSyn,
          TSynSDDSyn, TSynSQLSyn, TSynSMLSyn, TSynTclTkSyn, TSynVBSyn,
          TSynAsmSyn, TSynCppSyn, TSynPythonSyn, TSynPasSyn]);
      try // try to load the component
        myExporter.Highlighter :=
          FileToComponent(sHighlighter) as TSynCustomHighlighter;
      except
        // failed to load the component, it must have been invalid!
        log('External highlighter named ''' + sHighlighter + ''' is inavlid!');
        Exit;
      end;
    end
    else
    begin
      log('No external highlighter named ''' + sHighlighter + ''' found!');
      Exit;
    end;
  end;

  // Note: if not highlighter was specifed, and none can be found based on
  // extension then we can export without a highlighter which results in
  // no syntax highlighting, but does change the format.

  // nothing caused us to exit along the way, we must have everything we need.
  // list it out in the log window
  Log('Intput file: ' + sInFile + #126 +
    'Output file: ' + sOutFile + #126 +
    'Highlighter: ' + sHighlighter);

  // Now we call Perform Highlight with the final parameters.
  PerformHighlight(sInFile, sOutFile, myExporter);
end;

{ After all that work, all we did is protect the actual functionality of
this program from the user.  We should now have valid parameters for this
method. }

procedure TformSynEdit.PerformHighlight(const sInFile, sOutFile: string;
  sceHighlighter: TSynCustomExporter);
var
  slSrc: TStringList;
begin
  slSrc := TStringList.Create; // to load the source code into
  try
    // load the source code from disk
    slSrc.LoadFromFile(sInFile);
    sceHighlighter.ExportAsText := True;
    // Might be a good idea to make this user definable at some point, but for
    // now we will just us a generic title
    sceHighlighter.Title := ExtractFileName(sInFile) + ' source code';
    // Read in the source code and convert it to the highlighter format
    sceHighlighter.ExportAll(slSrc);
    // Save the output to disk.
    sceHighlighter.SaveToFile(sOutFile);
  finally
    slSrc.Free; // all done
  end;
end;

{Now assign an event handler to the Form Show event.  You could use a button
instead if you wanted.  You might also want to close when it is done.}

procedure TformSynEdit.FormShow(Sender: TObject);
begin
  Application.ProcessMessages; // finish drawing the form
  ParseParameters; // Get Started.
end;

end.

How to detect if a CPU supports MMX

Problem/Question/Abstract:

How to detect if a CPU supports MMX

Answer:

You have to use the CPUID instruction. Bit 23 of the feature flags (for EAX = 1) indicate if a processor supports the MMX instructions. Here is an example of how it could be used for MMX detection only (on Delphi versions prior to D6, you'll need to replace CPUID by DB $0f,$a2):

function SupportsMMX: Boolean;
var
  Supported: LongBool;
asm
  pushad
  mov Supported, 0
  pushfd
  pop eax
  mov edx, eax
  xor eax, 1 shl 21
  push eax
  popfd
  pushfd
  pop eax
  xor eax, edx
  and eax, 1 shl 21  {only if bit 21 can toggle, CPUID is supported}
  jz @ending  {if not, then exit}
  xor eax, eax
  cpuid
  cmp eax, 0  {check highest input value for CPUID}
  je @ending  {if highest value is zero, then exit}
  mov eax, 1
  cpuid  {We only need feature flags}
  test edx, 1 shl 23
  jz @ending
  inc Supported
@ending:
  popad
  mov eax, DWORD PTR Supported
end;

CPUID causes a lot of overhead, so make sure you call it only once during initialization and store the result somewhere to consult at any later stage. All remarks made apply to Intel processors unless specifiedotherwise

Get all Environment Strings

Problem/Question/Abstract:

Sometimes you want to show the user the current settings on his/her machine. One of the vital information are the Environment Strings. The Windows API gives us an efficient set of funcitons to access these

Answer:

Solve 1:

Actually, it is really easy to access the Windows Environment Strings. The Windows API defines a function called "GetEnvironmentStrings" to return a double-null terminated buffer filled with null terminated strings seperating all environment variables.

The following procedure will takes a string list as parameter and fill it with all environment variables returned. It will parse the buffer string by string, setting a pointer behind every string returned in order to retrieve the next one.

I hope this will help you.

procedure LoadEnvironmentStrings(Strings: TStrings);
var
  AllStrings, CurrentString: PChar;
begin
  AllStrings := GetEnvironmentStrings;
  try
    if AllStrings <> nil then
    begin
      CurrentString := AllStrings;
      while True do
      begin
        Strings.Add(StrPas(CurrentString));
        Inc(CurrentString, Succ(StrLen(CurrentString)));
        if CurrentString[0] = #0 then
          Break;
      end;
    end;
  finally
    FreeEnvironmentStrings(AllStrings);
  end;
end;


Solve 2:

GetEnvStringsList(TStringList(Memo1.Lines));

procedure GetEnvStringsList(EnvStr: TStringList);
var
  PEnv, PCopyEnv: pchar;
begin
  EnvStr.Clear;
  PEnv := GetEnvironmentStrings;
  PCopyEnv := PEnv;
  if PCopyEnv <> nil then
    repeat
      EnvStr.Add(StrPas(PCopyEnv));
      inc(PCopyEnv, StrLen(PCopyEnv) + 1);
    until PCopyEnv^ = #0;
  FreeEnvironmentStrings(PEnv);
  PCopyEnv := nil;
end;

List all User Identities in a ComboBox

Problem/Question/Abstract:

List all User Identities in a ComboBox

Answer:

The handy procedure GetIdentities() retrieves all user identities on a Windows system and and returns them for display in a TComboBox.

This can be useful for email tools.

procedure GetIdentities(cbIdentities: TComboBox);
var
  slIdentities: TStringList;
  sUser: string;
  sLastUsername: string;
  i: Integer;
begin { GetIdentities }
  cbIdentities.Items.Clear;
  sLastUsername := '';
  slIdentities := TStringList.Create;
  with TRegistry.Create do
  begin
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('Identities', False) then
    begin
      sLastUsername := ReadString('Last Username');
      GetKeyNames(slIdentities);
      CloseKey;
    end; { OpenKey() }

    // get all the user names
    for i := 0 to slIdentities.Count - 1 do
    begin
      if OpenKey('Identities\' + slIdentities[i], False) then
      begin
        sUser := ReadString('Username');
        cbIdentities.Items.Add(sUser + ' - ' + slIdentities[i]);
        if sUser = sLastUsername then
          cbIdentities.ItemIndex := i;
        CloseKey;
      end; { OpenKey() }
    end; { for i }
    Free;
  end; { with TRegistry.Create }
  slIdentities.Free;
end; { GetIdentities }

Flat/Hot track effect for components

Problem/Question/Abstract:

How can I add the hot track effect to my component?

Answer:

If you want to add a useful feature to your component (like URL in html or PageControl/TabControl.HotTrack) you must handle the CM_MOUSEENTER and CM_MOUSELEAVE messages:

type
  TyourControl = class(TDescControl)
  private
    { Private declarations }
    FLinkFont: TFont;
    FPassiveFont: TFont;

    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
  end;

implementation

procedure TyourControl.CMMouseEnter(var Msg: TMessage);
begin
  //Change color when mouse is over control
  Font.Assign(FLinkFont);
end;

procedure TyourControl.CMMouseLeave(var Msg: TMessage);
begin
  //Change color when mouse leaves control
  Font.Assign(FPassiveFont);
end;

As example, you can view a sources of the TURLLabel and/or THighLightLabel components on my site (http://www.geocities.com/mshkolnik).

How to tell if a selected font is a True Type font

Problem/Question/Abstract:

How to tell if a selected font is a True Type font

Answer:

Solve 1:

uses
  SysUtils, WinTypes, Classes, Forms, Dialogs, StdCtrls, Controls;

function isTrueType(FontName: string): Boolean;
  procedure Button1Click(Sender: TObject);

    procedure TForm1.Button1Click(Sender: TObject);
    begin
      if isTrueType('Courier') then
        showmessage('Is a true type font')
      else
        showmessage('Not true type');
    end;

    function EnumFontFamProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
      FontType: Integer; TF: TForm1): Integer; export; stdcall;
    begin
      Result := 1;
      if FontType and TRUETYPE_FONTTYPE > 0 then
        Result := 0; {stop enumerating}
    end;

    function TForm1.isTrueType(FontName: string): Boolean;
    var
      Buffer: array[0..255] of Char;
    begin
      StrPCopy(Buffer, FontName);
      result := (EnumFontFamilies(Canvas.Handle, Buffer, @EnumFontFamProc, LongInt(Self)) = false);
    end;


Solve 2:

function IsTrueType(const FaceName: string): Boolean;
var
  Canvas: TCanvas;
  DC: THandle;
  TextMetric: TTextMetric;
begin
  Canvas := TCanvas.Create;
  try
    DC := GetDC(GetDesktopWindow);
    try
      Canvas.Handle := DC;
      Canvas.Font.Name := FaceName;
      GetTextMetrics(Canvas.Handle, TextMetric);
      Result := (TextMetric.tmPitchAndFamily and TMPF_TRUETYPE) <> 0;
    finally
      ReleaseDC(GetDesktopWindow, DC);
    end;
  finally
    Canvas.Free;
  end;
end;

Automate word 8 (aka word97)?

Problem/Question/Abstract:

How do I automate word 8 (aka word97)?  

Answer:

You can get to any of the interfaces exposed by the word automation server. These can be found by loading the file "MSWORD8.OLB" into Delphi which will display the type library information. The following code sample demonstrates creating a new word document and inserting text into the document via automation.

uses ComObj;

procedure TForm.Button Click(Sender: TObject);
var
  Word97: Variant;
begin
  Word97 := CreateOLEObject('Word.Application');
  Word97.Documents.Add;
  Word97.Selection.TypeText('Wow BOB woW');
  Word97.Visible := True;
  Word97 := UnAssigned;
end;

How to do frame animation with the TImageList class

Problem/Question/Abstract:

How to do frame animation with the TImageList class

Answer:

As users become more savvy, they begin to expect more sophisticated features from every software package they buy. Accordingly, if the applications you produce don't seem up-to-date, users probably won't be satisfied with your software. One way to make your applications more visually appealing is by using attractive graphics, and even animation. Unfortunately, animation has become something of a black art within programming circles, and many competent programmers avoid it because the realm of motion graphics appears to be so complex.

Last month, we introduced you to the TImageList class and demonstrated how it can help display non-rectangular bitmaps ("Drawing Non-Rectangular Bitmaps with a TImageList"). Delphi 2.0 defines a new version of the TImageList class, which encapsulates behavior for the new windows Image List common control. In a future issue, we'll discuss the relative merits of the new TImageList class. In this article, we'll show how you can use the Delphi 1.0 TImageList class to perform a simple type of animation called frame animation.



Animation clarification:

There are two predominant forms of animation that most computer programs currently use - frame animation and cast animation. Of the two, cast animation is more complex, but also more flexible.

In frame animation, you prepare a series of entire scenes and show those scenes in quick succession to give the illusion of movement. This is how cartoon animation works and how videotape stores picture information.

In contrast, cast animation separates information about the background from the moveable elements. This arrangement allows you to create a small image (called a sprite) that moves around on a background, without recording in advance all of the possible positions, as you would do with frame animation.



Framed, and enjoying it

Delphi provides several types of components and objects that you'll commonly use to display and manipulate graphic images. As you might expect, some of these components and objects are very useful for displaying graphics, but most of them are inappropriate for such complex tasks as frame animation.

For example, Image components make it simple to display a single bitmap image. However, they're not necessarily better for animation than PaintBox components, which use the Canvas of their parent forms for drawing purposes.

Similarly, a TBitmap object is useful for storing a single image, but you wouldn't want to create a separate TBitmap object for each frame of an animation sequence. If you did, you'd need to track every object, each of which requires its own color palette, thus wasting memory. (This is particularly true if you're displaying 256-color bitmaps on a system that has a Super VGA video adapter.)

The TImageList class provides a different set of benefits. Since it's designed to manage a set of identically-sized bitmap images, the TImageList class stores several images in an internal TBitmap object and, therefore, uses the same palette for all of them. As a result, the TImageList class is an ideal core element of frame- animation code. For more information on the internal workings of the TImageList class, see "How TImageList objects manage bitmaps".

To perform frame animation, you'll add each frame image to a TImageList object. Then, you'll use the TImageList object's Draw() method to draw one of the specific bitmaps the list contains.

The Draw() method accepts three parameters: the destination Canvas, the horizontal and vertical coordinates of the top-left corner within the source image, and the index of the source image within the list. By simply changing the value of the index parameter, you can choose to draw any of the images the TImageList object contains.

By the way, when you've finished using a TImageList object, you're responsible for releasing its memory by calling its Free method. The only remaining problem is how to eliminate some of the all-too-common flicker that sometimes occurs when you call the Repaint or Refresh methods.



My friend flicker

If you've ever considered animation programming, you're probably familiar with the term double-buffering. If you've never heard the term, don't worry; you're not alone.

Because it takes time to load an image from a file or compose an image by using various graphics operations, you don't want to perform these operations directly onscreen. If you do, you'll probably notice a significant amount of flicker in the displayed image, since Image and Bitmap components will automatically repaint themselves when you modify them.

In double-buffering, you maintain a temporary location - such as a TBitmap object that isn't visible - for building the new image you want to display. When you're ready to display the image, you can simply use the CopyRect() method of the TBitmap class to quickly transfer the information from the invisible TBitmap object (typically called an offscreen bitmap) to a PaintBox or Image component. Since the CopyRect() method is very fast (relatively speaking), you'll reduce or eliminate visible flicker when you update the image onscreen.

Since the TImageList class maintains its own internal TBitmap object (to store all the images), it has exactly what we need to store multiple images and double-buffer them! Since we'll probably want to use the TImageList class with a PaintBox component on a regular basis, let's consider what we'll need to do to combine these elements into a single new animation component.



The "Animator"

Since our animation component is primarily a device for displaying a series of bitmap images, we'll derive the TAnimator class from the TPaintBox class. By doing so, the TAnimator objects will automatically acquire the benefits of a PaintBox component, such as being able to use its owner's Canvas instead of having to create an additional Canvas of its own.

Within the TAnimator class, we'll need to create a TImageList object to contain all the animation images. To simplify the interface for this component, we'll assume that any programmer using this component will understand the basics of the TImageList class. Accordingly, we'll make this object accessible by creating a runtime, read- only property named ImageList, which you can use to access the methods of the internal TImageList object.

Since the size of the images you want to display may not be the same as the initial size of the animation component, we'll create a ResizeImageList() method. This method will destroy the current internal TImageList and create a new one based on the size parameters that you pass to the method.

Next, we'll provide a public method named Animate, which tells the animation component to advance to the next frame and draw it. When we do so, we must avoid embedding a Timer component or any other type of time-related interval code, because different applications will have different timing requirements.

For instance, if you're creating animation within an about box, you could place a simple timer in the code that counts the number of WM_IDLE messages the application receives. In contrast, if your application is a game that will run under Windows 95 or Windows NT, you may want to trigger the animation sequence using a thread and the SleepEx() function or the ThreadedTimer component we showed you how to build last month ("Creating a Threaded Timer for Delphi 2.0").

Appropriately, we've added some code that allows you to use this component under Delphi 2.0. In a future issue, we'll examine the full capabilities of the new TImageList class. For now, recognize that the new version provides all the capabilities of the old version if you configure it properly.

Last but not least, we'll provide a runtime, read-only property named CurrentIndex, which will identify the image the animation component is currently displaying. Now let's build the Animator component. Afterwards, we'll create a simple animation form that uses the Animator component to display a series of bitmaps.



Animation preparation

To begin, use the Component Expert dialog box to create a new component source file. Enter TAnimator as the Class Name, TPaintBox as the Ancestor Type, and DelphiJournal as the Palette Page. Click OK to create the new source file.

When the new source file appears, enter the appropriate code from Listing A. (For each listing in this article, we've highlighted in bold the code you'll need to enter.) When you finish entering the code, save the file as ANIMATOR.PAS.

{Listing A: ANIMATOR.PAS }

unit Animator;

interface

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

type
  TAnimator = class(TPaintBox)
  private
    { Private declarations }
    FImageList: TImageList;
    FCurrentIndex: Integer;
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Animate;
    procedure ResizeImageList(X, Y: Integer);
    property ImageList: TImageList
      read FImageList;
    property CurrentIndex: Integer
      read FCurrentIndex;
  published
    { Published declarations }
  end;

procedure Register;

implementation

constructor
  TAnimator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
{$IFDEF VER80} {If Delphi 1.x}
  FImageList := TImageList.Create(Width, Height);
{$ELSE} {If Delphi 2.0}
  FImageList := TImageList.CreateSize(Width, Height);
  FImageList.Masked := False;
{$ENDIF}
  FCurrentIndex := 0;
end;

destructor
  TAnimator.Destroy;
begin
  FImageList.Free;
  inherited Destroy;
end;

procedure TAnimator.ResizeImageList(X, Y: Integer);
begin
  FImageList.Free;
{$IFDEF VER80} {If Delphi 1.x}
  FImageList := TImageList.Create(X, Y);
{$ELSE} {If Delphi 2.0}
  FImageList := TImageList.CreateSize(X, Y);
  FImageList.Masked := False;
{$ENDIF}
end;

procedure TAnimator.Animate;
begin
  Inc(FCurrentIndex);
  if FCurrentIndex >= FImageList.Count then
    FCurrentIndex := 0;
  Paint;
end;

procedure TAnimator.Paint;
begin
  if FImageList.Count > 0 then
    FImageList.Draw(Canvas, 0, 0, FCurrentIndex)
  else
    inherited Paint;
end;

procedure Register;
begin
  RegisterComponents(`Test', [TAnimator]);
end;

end.



Next, use the Install Components dialog box to add the ANIMATOR.PAS file to the list of Installed Units. Click OK to compile the ANIMATOR.PAS file and link it to the new version of the Component Library.



Animation demonstration

To see how the Animator component works, you must first create a new blank form project. Then, place a Timer component, an Image component, and an Animator component on the form.

Next, create event-handling methods for the form's OnCreate event property and the Timer component's OnTimer property. Now enter the appropriate source code from Listing B. When you finish, save the form file as ANIMATE.PAS, and save the project as ANIM_P.DPR.

{Listing B: ANIMATE.PAS }

unit Animate;

interface

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

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Image1: TImage;
    Animator1: TAnimator;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    MyList: TImageList;
    ImageIndex: Integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  WorkBmp: TBitmap;
  Offset: Integer;

  procedure AddImage;
  begin
    Image1.Picture.Bitmap.Width := WorkBmp.Width + Offset;
    Image1.Picture.Bitmap.Canvas.Draw(Offset, 0, WorkBmp);
    Animator1.ImageList.Add(WorkBmp, nil);
    Inc(Offset, WorkBmp.Width);
  end;

begin
  WorkBmp := TBitmap.Create;
  WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1d.bmp');
    Offset := 0;
    Animator1.ResizeImageList(WorkBmp.Width, WorkBmp.Height);
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1dl.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1l.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1ul.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1u.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1ur.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1r.bmp');
    AddImage;
    WorkBmp.LoadFromFile(`C: \delphi\images\buttons\arrow1dr.bmp');
    AddImage;
    ImageIndex := 0;
    WorkBmp.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Animator1.Animate;
end;

end.

Then, double-click on the Image component, and load one of the button bitmaps from the \DELPHI\IMAGES\BUTTONS directory. It doesn't matter which button, since we'll replace it with the images of several other button bitmaps.

Now, build and run the application. When the main form appears, you'll notice the arrow images spinning slowly in the Animator component's area. Immediately below, you'll notice that we display all the different button bitmaps in the Image component, as shown in Figure A.

In fact, this is the way the TImageList class stores the bitmap images that it draws in the Animator component's area. As the Timer component's interval expires, it calls the Animate method of the Animator com-ponent, which, in turn, draws the next image from its internal bitmap.



Conclusion

Even simple frame animation can be a complex undertaking if you manage all the display tasks yourself. Fortunately, the TImageList class takes care of many details for us, such as double-buffering image information and storing all the images in a single bitmap. By wrapping a TImageList object and the capabilities of the TPaintBox class together in a new component, as we've shown here, you can easily add an animation sequence to your next Delphi project.

Switch Keyboard for your application

Problem/Question/Abstract:

Switch Keyboard for your application

Answer:

Solve 1:

Following code will activate 'Greek' Keyboard Layout for the application.

var
  LangIdentifier: string;
begin
  LangIdentifier := '00000408'; //'0000408' is the Language Identifier for Greek
  LoadKeyboardLayout(PChar(LangIdentifier), KLF_ACTIVATE);
end;

PS: This would only Load the Keyboard Layouts which are installed on that very machine otherwise there would be no affect.


Solve 2:

If you want to change a current keyboard layout, you can:

1

var
  lang: HKL;
  lang := LoadKeyboardLayout(pcKeyboard, 0);
  SetActiveKeyboardLayout(lang);

2

LoadKeyboardLayout(pcKeyboard, KLF_ACTIVATE);

where pcKeyboard is:

'00000409' - english
'00000419' - russian
'00000422' - ukrainian
'00000407' - german
'0000040C' - french
'00000410' - italian
'00000416' - portuguese
'0000040A' - spanish

... (for more information view a language consts in windows.pas)

Selecting a printer

Problem/Question/Abstract:

PrinterIndex selects the current printer but also applies the properties of the currently active printer.

Answer:

Q: How to change the current printer ?

A: Printer.PrinterIndex := Printer.Printers.IndexOf('printername'); ???

The answer is certainly correct, but there is also a problem. This problem came up when developing a label printing program for DHL shipping labels using the form design and print library WPForm&Report under Delphi 5: although the mentioned code selects the printer (this is good) it also applies the properties of the standard printer to the newly selected printer. So any preselected paper format is lost and the printer (in our case it was a big Siemens label printer) used a wrong paper format.

Although it took a while to find this ot, the solution was not too difficult:

The only possible solution for us was making a copy of the original printers.pas file and changing it. The new printer unit was linked to the project instead of the old one. (I know, such a change is unfortunate but there are no virtual methods in the TPrinter object so overriding of the method 'SetPrinterIndex' is not possible)

This code shows you the necessary changes. The idea was to read out the properties of the newly selected printer before it is activated for printing.

procedure TWPFPrinter.SetPrinterIndex(Value: Integer);
var
  DrvHandle: THandle;
  ExtDevCaps: TFarProc;
  DriverName: string;
  ExtDevCode: Integer;
  OutDevMode: PDevMode;
  ADevice: array[0..256] of Char;
  StubDevMode: TDeviceMode;
begin
  CheckPrinting(False);
  if (Value = -1) or (PrinterIndex = -1) then
    SetToDefaultPrinter
  else if (Value < 0) or (Value >= Printers.Count) then
    RaiseError(SPrinterIndexError);
  FPrinterIndex := Value;
  FreeFonts;
  SetState(psNoHandle);
  // ------------------------------------------------------------------------
  // Now we load the currently selected properties of the
  // newly selected printer.
  // otherwise the same 'DeviceMode' memory block to initialize the new printer
  // ------------------------------------------------------------------------
  if DeviceMode <> 0 then
  begin
    GlobalUnlock(DeviceMode);
    GlobalFree(DeviceMode);
    DeviceMode := 0;
  end;
  // ------------------------------------------------------------------------
  // This code was copied from the SetPrinters procedure
  // ------------------------------------------------------------------------
  with TPrinterDevice(Printers.Objects[PrinterIndex]) do
    StrCopy(ADevice, PChar(Device));
  if OpenPrinter(ADevice, FPrinterHandle, nil) then
  begin
    if DeviceMode = 0 then // alloc new device mode block if one was not passed in
    begin
      DeviceMode := GlobalAlloc(GHND,
        DocumentProperties(0, FPrinterHandle, ADevice, StubDevMode,
        StubDevMode, 0));
      if DeviceMode 0 then
      begin
        DevMode := GlobalLock(DeviceMode);
        if DocumentProperties(0, FPrinterHandle, ADevice, DevMode^,
          DevMode^, DM_OUT_BUFFER) < 0 then
        begin
          GlobalUnlock(DeviceMode);
          GlobalFree(DeviceMode);
          DeviceMode := 0;
        end
      end;
    end;
    if DeviceMode 0 then
      SetPrinterCapabilities(DevMode^.dmFields);
  end;
end;