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;