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;