How to create a database at run-time with ZEOS

Problem/Question/Abstract:

How can I create a database at run-time with ZEOS?

Answer:

// Torry's Delphi Tips
// Author Rolf Warnecke
// Listed 29.03.2003

{
This unit creates a database on a Interbase-Server at run-time.
The IBConsole is no longer needed.
You can execute an SQL script to create tables.
Try it out!
}

{
Diese Unit erstellt eine Datenbank auf einem Interbase - Server zur Laufzeit des Programms.
Es wird nicht mehr die IBConsole gebraucht.
Dazu kann man im Memo noch ein SQL - Skript ablaufen lassen zum erstellen der Tabellen.
Probiert es einfach aus.
}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ZTransact, ZIbSqlTr, DB, ZQuery, ZIbSqlQuery,
ZConnect, ZIbSqlCon;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
ZIbSqlQuery1: TZIbSqlQuery;
ZIbSqlTransact1: TZIbSqlTransact;
ZIbSqlDatabase1: TZIbSqlDatabase;
Button3: TButton;
procedure Button1Click(Sender: TObject);
// Caption/ Beschriftung : Create Database
procedure Button2Click(Sender: TObject); // Caption/ Beschriftung : SQL-Anweisung
procedure Button3Click(Sender: TObject); // Caption/ Beschriftung : Drop Database
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

// Creating the database
// Hier wird durch dr�cken des Buttons die Datenbank erstellt
//---------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlDatabase1.CreateDatabase('');
end;

// Execute the SQL-Script in the memo
// Hier wird durch dr�cken des Buttons das SQL-Skript im Memo ausgef�hrt
//----------------------------------------------------------------------

procedure TForm1.Button2Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlQuery1.SQL.Clear;
ZIbSqlQuery1.SQL.AddStrings(memo1.Lines);
ZIbSqlQuery1.ExecSQL;
end;

// Deleted the database
// Hier wird durch dr�cken des Buttons die Datenbank komplette gel�scht
//---------------------------------------------------------------------

procedure TForm1.Button3Click(Sender: TObject);
begin
ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
ZIbSqlDatabase1.Host := 'testserver';
ZIbSqlDatabase1.Password := 'masterkey';
ZIbSqlDatabase1.Login := 'SYSDBA';
ZIbSqlDatabase1.DropDatabase;
end;

end.

Converting a Bitmap to RTF code

Problem/Question/Abstract:

How do I convert a Bitmap to RTF code?

Answer:

function BitmapToRTF(pict: TBitmap): string;
var
bi, bb, rtf: string;
bis, bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap0 ';
SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := IntToHex(Integer(bi[bis]), 2);
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
for bbs := 1 to Length(bb) do
begin
achar := IntToHex(Integer(bb[bbs]), 2);
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;

Join two TMetaFile

Problem/Question/Abstract:

I wish to join two *.wmf files together - adding one to the end of the other.

Answer:

{ ... }
MetaFile1 := TMetaFile.Create;
MetaFile2 := TMetaFile.Create;
DestMetaFile := TMetaFile.Create;
try
MetaFile1.LoadFromFile('A0000259.WMF');
MetaFile2.LoadFromFile('A0000260.WMF');
DestMetaFile.Width := Max(MetaFile1.Width, MetaFile2.Width);
DestMetaFile.Height := MetaFile1.Height + MetaFile2.Height;
MetaFileCanvas := TMetaFileCanvas.Create(DestMetaFile, 0);
try
MetaFileCanvas.Draw(0, 0, MetaFile1);
MetaFileCanvas.Draw(0, MetaFile1.Height, MetaFile2);
finally
MetaFileCanvas.Free;
end;
DestMetaFile.SaveToFile('new.wmf');
finally
MetaFile1.Free;
MetaFile2.Free;
DestMetaFile.Free;
end;
{ ... }

VCL MS Word Spell Check and Thesaurus

Problem/Question/Abstract:

VCL MS Word Spell Check and Thesaurus

Answer:

This is the VCL for Spell Checking and Synonyms using MS Word COM interface. It can correct and replace words in a Text String,TMemo or TRichEdit using a built in replacement editor, or can be controlled by user dialog. I see there are other callable functions in the interface, which I have not implemented. Anyone see a use for any of them ?.

They are ...
  
    property PartOfSpeechList: OleVariant  read Get_PartOfSpeechList;
    property AntonymList: OleVariant read Get_AntonymList;
    property RelatedExpressionList: OleVariant  read Get_RelatedExpressionList;
    property RelatedWordList: OleVariant  read Get_RelatedWordList;

Example of checking and changing a Memo text ...

    SpellCheck.CheckMemoTextSpelling(Memo1);

Properties
----------------
LetterChars            - Characters considered to be letters. default is  
                                   ['A'..'Z','a'..'z'] (English) but could be changed to
                                   ['A'..'Z','a'..'z','�','�','�','�','�'] (Spanish)

Color                       - Backgound color of Default dialog Editbox and Listbox

CompletedMessage - Enable/Disable display of completed and count message dialog

Font                         - Font of Default dialog Editbox and Listbox

Language                - Language used by GetSynonyms() method

ReplaceDialog         - Use Default replace dialog or User defined  (see events)

Active                      - Readonly, set at create time. Indicates if MS Word is  available

Methods
----------------
function GetSynonyms(StrWord : string; Synonyms : TStrings) : boolean;

         True if synonyms found for StrWord. Synonyms List is  
         returned in TStrings (Synonyms).

function CheckWordSpelling(StrWord : string; Suggestions : TStrings) : boolean;

         True if StrWord is spelt correctly. Suggested corrections
         returned in TStrings (Suggestions)

procedure CheckTextSpelling(var StrText : string);

          Proccesses string StrText and allows users to change  
          mispelt  words via a Default replacement dialog or User  
          defined calls. Words are changed and returned in StrText.
          Words in the text are changed automatically by the Default
          editor. Use the  events if you want to control the dialog
          yourself. ie. Get the mispelt word, give a choice of
          sugesstions (BeforeCorrection), Change the word to
          corrected  (OnCorrection) and possibly display "Was/Now"
          (AfterCorrection)

procedure CheckRichTextSpelling(RichEdit : TRichEdit);

         Corrects misspelt words directly in TRichEdit.Text.
         Rich Format is maintained.

procedure CheckMemoTextSpelling(Memo : TMemo);

         Corrects misspelt words directly into a TMemo.Text.


Events (Mainly used when ReplaceDialog = repUser)
--------------------------------------------------------------------------------
BeforeCorrection - Supplies the mispelt word along with a TStrings
                                 var containing suggested corrections.

OnCorrection       - Supplies the mispelt word as a VAR type allowing
                                user to change it to desired word. The word will be
                                replaced by this variable in the passed StrText.

AfterCorrection  - Supplies the mispelt word and what it has been
                               changed to.


unit SpellChk;
interface

// =============================================================================
// MS Word COM Interface to Spell Check and Synonyms
// Mike Heydon Dec 2000
// mheydon@pgbison.co.za
// =============================================================================

uses Windows, SysUtils, Classes, ComObj, Dialogs, Forms, StdCtrls,
  Controls, Buttons, Graphics, ComCtrls, Variants;

// Above uses Variants is for Delphi 6 - remove for Delphi 5 and less

type
  // Event definitions
  TSpellCheckBeforeCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    Suggestions: TStrings) of object;

  TSpellCheckAfterCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    CorrectedWord: string) of object;

  TSpellCheckOnCorrection = procedure(Sender: TObject;
    var WordToCorrect: string) of object;

  // Property types
  TSpellCheckReplacement = (repDefault, repUser);
  TSpellCheckLetters = set of char;

  TSpellCheckLanguage = (wdLanguageNone, wdNoProofing, wdDanish, wdGerman,
    wdSwissGerman, wdEnglishAUS, wdEnglishUK, wdEnglishUS,
    wdEnglishCanadian, wdEnglishNewZealand,
    wdEnglishSouthAfrica, wdSpanish, wdFrench,
    wdFrenchCanadian, wdItalian, wdDutch, wdNorwegianBokmol,
    wdNorwegianNynorsk, wdBrazilianPortuguese,
    wdPortuguese, wdFinnish, wdSwedish, wdCatalan, wdGreek,
    wdTurkish, wdRussian, wdCzech, wdHungarian, wdPolish,
    wdSlovenian, wdBasque, wdMalaysian, wdJapanese, wdKorean,
    wdSimplifiedChinese, wdTraditionalChinese,
    wdSwissFrench, wdSesotho, wdTsonga, wdTswana, wdVenda,
    wdXhosa, wdZulu, wdAfrikaans, wdArabic, wdHebrew,
    wdSlovak, wdFarsi, wdRomanian, wdCroatian, wdUkrainian,
    wdByelorussian, wdEstonian, wdLatvian, wdMacedonian,
    wdSerbianLatin, wdSerbianCyrillic, wdIcelandic,
    wdBelgianFrench, wdBelgianDutch, wdBulgarian,
    wdMexicanSpanish, wdSpanishModernSort, wdSwissItalian);

  // Main TSpellcheck Class
  TSpellCheck = class(TComponent)
  private
    MsWordApp,
      MsSuggestions: OleVariant;
    FLetterChars: TSpellCheckLetters;
    FFont: TFont;
    FColor: TColor;
    FReplaceDialog: TSpellCheckReplacement;
    FCompletedMessage,
      FActive: boolean;
    FLanguage: TSpellCheckLanguage;
    FForm: TForm;
    FEbox: TEdit;
    FLbox: TListBox;
    FCancelBtn,
      FChangeBtn: TBitBtn;
    FBeforeCorrection: TSpellCheckBeforeCorrection;
    FAfterCorrection: TSpellCheckAfterCorrection;
    FOnCorrection: TSpellCheckOnCorrection;
    procedure SetFFont(NewValue: TFont);
  protected
    procedure MakeForm;
    procedure CloseForm;
    procedure SuggestedClick(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetSynonyms(StrWord: string; Synonyms: TStrings): boolean;
    function CheckWordSpelling(StrWord: string;
      Suggestions: TStrings): boolean;
    procedure CheckTextSpelling(var StrText: string);
    procedure CheckRichTextSpelling(RichEdit: TRichEdit);
    procedure CheckMemoTextSpelling(Memo: TMemo);
    procedure Anagrams(const InString: string; StringList: TStrings);
    property Active: boolean read FActive;
    property LetterChars: TSpellCheckletters read FLetterChars write FLetterChars;
  published
    property Language: TSpellCheckLanguage read FLanguage
      write FLanguage;
    property CompletedMessage: boolean read FCompletedMessage
      write FCompletedMessage;
    property Color: TColor read FColor write FColor;
    property Font: TFont read FFont write SetFFont;
    property BeforeCorrection: TSpellCheckBeforeCorrection
      read FBeforeCorrection
      write FBeforeCorrection;
    property AfterCorrection: TSpellCheckAfterCorrection
      read FAfterCorrection
      write FAfterCorrection;
    property OnCorrection: TSpellCheckOnCorrection
      read FOnCorrection
      write FOnCorrection;
    property ReplaceDialog: TSpellCheckReplacement
      read FReplaceDialog
      write FReplaceDialog;
  end;

procedure Register;

// -----------------------------------------------------------------------------
implementation

// Mapped Hex values for ord(FLanguage)
const

  LanguageArray: array[0..63] of integer =
  ($0, $400, $406, $407, $807, $C09, $809, $409,
    $1009, $1409, $1C09, $40A, $40C, $C0C, $410,
    $413, $414, $814, $416, $816, $40B, $41D, $403,
    $408, $41F, $419, $405, $40E, $415, $424, $42D,
    $43E, $411, $412, $804, $404, $100C, $430, $431,
    $432, $433, $434, $435, $436, $401, $40D, $41B,
    $429, $418, $41A, $422, $423, $425, $426, $42F,
    $81A, $C1A, $40F, $80C, $813, $402, $80A, $C0A, $810);

  // Change to Component Pallete of choice

procedure Register;
begin
  RegisterComponents('MahExtra', [TSpellCheck]);
end;

// TSpellCheck

constructor TSpellCheck.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // Defaults
  FLetterChars := ['A'..'Z', 'a'..'z'];
  FCompletedMessage := true;
  FColor := clWindow;
  FFont := TFont.Create;
  FReplaceDialog := repDefault;
  FLanguage := wdEnglishUS;

  // Don't create an ole server at design time
  if not (csDesigning in ComponentState) then
  begin
    try
      MsWordApp := CreateOleObject('Word.Application');
      FActive := true;
      MsWordApp.Documents.Add;
    except
      on E: Exception do
      begin
        // MessageDlg('Cannot Connect to MS Word',mtError,[mbOk],0);
        // Activate above if visual failure required
        FActive := false;
      end;
    end;
  end;
end;

destructor TSpellCheck.Destroy;
begin
  FFont.Free;

  if FActive and not (csDesigning in ComponentState) then
  begin
    MsWordApp.Quit;
    MsWordApp := VarNull;
  end;

  inherited Destroy;
end;

// ======================================
// Property Get/Set methods
// ======================================

procedure TSpellCheck.SetFFont(NewValue: TFont);
begin
  FFont.Assign(NewValue);
end;

// ===========================================
// Return a list of synonyms for single word
// ===========================================

function TSpellCheck.GetSynonyms(StrWord: string;
  Synonyms: TStrings): boolean;
var
  SynInfo: OleVariant;
  i, j: integer;
  TS: OleVariant;
  Retvar: boolean;
begin
  Synonyms.Clear;

  if FActive then
  begin
    SynInfo := MsWordApp.SynonymInfo[StrWord,
      LanguageArray[ord(FLanguage)]];
    for i := 1 to SynInfo.MeaningCount do
    begin
      TS := SynInfo.SynonymList[i];
      for j := VarArrayLowBound(TS, 1) to VarArrayHighBound(TS, 1) do
        Synonyms.Add(TS[j]);
    end;

    RetVar := SynInfo.Found;
  end
  else
    RetVar := false;

  Result := RetVar;
end;

// =======================================
// Check the spelling of a single word
// Suggestions returned in TStrings
// =======================================

function TSpellCheck.CheckWordSpelling(StrWord: string;
  Suggestions: TStrings): boolean;
var
  Retvar: boolean;
  i: integer;
begin
  RetVar := false;
  if Suggestions <> nil then
    Suggestions.Clear;

  if FActive then
  begin
    if MsWordApp.CheckSpelling(StrWord) then
      RetVar := true
    else
    begin
      if Suggestions <> nil then
      begin
        MsSuggestions := MsWordApp.GetSpellingSuggestions(StrWord);
        for i := 1 to MsSuggestions.Count do
          Suggestions.Add(MsSuggestions.Item(i));
        MsSuggestions := VarNull;
      end;
    end;
  end;

  Result := RetVar;
end;

// ======================================================
// Check the spelling text of a string with option to
// Replace words. Correct string returned in var StrText
// ======================================================

procedure TSpellCheck.CheckTextSpelling(var StrText: string);
var
  StartPos, CurPos,
    WordsChanged: integer;
  ChkWord, UserWord: string;
  EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (StartPos <= length(StrText)) and
      (not (StrText[StartPos] in FLetterChars)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of RichText with option to
// Replace words (in situ replacement direct to RichEdit.Text)
// =============================================================

procedure TSpellCheck.CheckRichTextSpelling(RichEdit: TRichEdit);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := RichEdit.HideSelection;
  RichEdit.HideSelection := false;
  StrText := RichEdit.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              RichEdit.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            RichEdit.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    RichEdit.HideSelection := SaveHide;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of Memo with option to
// Replace words (in situ replacement direct to Memo.Text)
// =============================================================

procedure TSpellCheck.CheckMemoTextSpelling(Memo: TMemo);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := Memo.HideSelection;
  Memo.HideSelection := false;
  StrText := Memo.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              Memo.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            Memo.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    Memo.HideSelection := SaveHide;
    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// ======================================================================
// Return a list of Anagrams - Careful, long words generate HUGE lists
// ======================================================================

procedure TSpellCheck.Anagrams(const InString: string; StringList: TStrings);
var
  WordsChecked, WordsFound: integer;

  procedure RecursePerm(const StrA, StrB: string; Len: integer; SL: TStrings);
  var
    i: integer;
    A, B: string;
  begin
    if (length(StrA) = Len) then
    begin
      inc(WordsChecked);
      if (SL.IndexOf(StrA) = -1) and MsWordApp.CheckSpelling(StrA) then
      begin
        inc(WordsFound);
        SL.Add(StrA);
        Application.ProcessMessages;
      end;
    end;

    for i := 1 to length(StrB) do
    begin
      A := StrB;
      B := StrA + A[i];
      delete(A, i, 1);
      RecursePerm(B, A, Len, SL);
    end;
  end;

begin
  if FActive then
  begin
    WordsChecked := 0;
    WordsFound := 0;
    StringList.Clear;
    Application.ProcessMessages;
    RecursePerm('', LowerCase(InString), length(InString), StringList);
    if FCompletedMessage then
      MessageDlg('Anagram Search Check Complete' + #13#10 +
        IntToStr(WordsChecked) + ' words checked' + #13#10 +
        IntToStr(WordsFound) + ' anagrams found',
        mtInformation, [mbOk], 0);
  end
  else
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0);
end;

// =========================================
// Create default replacement form
// =========================================

procedure TSpellCheck.MakeForm;
begin
  // Correction form container
  FForm := TForm.Create(nil);
  FForm.Position := poScreenCenter;
  FForm.BorderStyle := bsDialog;
  FForm.Height := 260; // 240 if no caption
  FForm.Width := 210;

  // Remove form's caption if desired
  //  SetWindowLong(FForm.Handle,GWL_STYLE,
  //                GetWindowLong(FForm.Handle,GWL_STYLE) AND NOT WS_CAPTION);

  FForm.ClientHeight := FForm.Height;

  // Edit box of offending word
  FEbox := TEdit.Create(FForm);
  FEbox.Parent := FForm;
  FEbox.Top := 8;
  FEbox.Left := 8;
  FEbox.Width := 185;
  FEBox.Font := FFont;
  FEbox.Color := FColor;

  // Suggestion list box
  FLbox := TListBox.Create(FForm);
  FLbox.Parent := FForm;
  FLbox.Top := 32;
  FLbox.Left := 8;
  FLbox.Width := 185;
  FLbox.Height := 193;
  FLbox.Color := FColor;
  FLbox.Font := FFont;
  FLbox.OnClick := SuggestedClick;
  FLbox.OnDblClick := SuggestedClick;

  // Cancel Button
  FCancelBtn := TBitBtn.Create(FForm);
  FCancelBtn.Parent := FForm;
  FCancelBtn.Top := 232;
  FCancelBtn.Left := 8;
  FCancelBtn.Kind := bkCancel;
  FCancelBtn.Caption := 'Ignore';

  // Change Button
  FChangeBtn := TBitBtn.Create(FForm);
  FChangeBtn.Parent := FForm;
  FChangeBtn.Top := 232;
  FChangeBtn.Left := 120;
  FChangeBtn.Kind := bkOk;
  FChangeBtn.Caption := 'Change';
end;

// =============================================
// Close the correction form and free memory
// =============================================

procedure TSpellCheck.CloseForm;
begin
  FChangeBtn.Free;
  FCancelBtn.Free;
  FLbox.Free;
  FEbox.Free;
  FForm.Free;
end;

// ====================================================
// FLbox on click event to populate the edit box
// with selected suggestion (OnClick/OnDblClick)
// ====================================================

procedure TSpellCheck.SuggestedClick(Sender: TObject);
begin
  FEbox.Text := FLbox.Items[FLbox.ItemIndex];
end;

end.

Using One Event for many Components

Problem/Question/Abstract:

Using One Event for many Components

Answer:

This tip is a pretty basic one, but if you haven't come across it, using it can make your coding a lot easier and more efficient.

Delphi allows one coded event to be assigned to many event handlers as long as the methods are of the same type - ie., they have the same arguments.  The classic example is the OnClick event which is shared by many components.  This can be done in code in the following way.

procedure ClickMyComponent(Sender: Tobject);
begin
  //Some code goes here
  ShowMessage('This is my Onclick handler');
end;

{You can then assign this procedure to as many event handlers as you wish.}

procedure AssignEvents;
begin
  MyButton.OnClick := ClickMyComponent;
  MyLabel.OnClick := ClickMyComponent;
  MyCombo.Onclick := ClickMyComponent;
  // You Get the message!
end;

Each time one of these components is clicked, the above procedure 'ClickMyComponent' is executed.  This can be useful is certain circumstances, but mainly in this tip it serves to illustrate my main point  - reduce designtime coding by assigning events.

Assigning at designtime.

In the object inspector you may have noticed that the right hand side of the events tab is a combo box.  This allows you to choose to assign an already written event handler to the current components event (only event handlers of the right type are shown in the combo box).  This is the design time way of doing the above code.

At a glance it can seem like a nice but essentially useless ability to have.  How often are you likely to have two buttons, or a button and a label that share the same onclick code.  This may be true but it does happen.  Also an area where you do have many controls sharing code is in respect to Main Menus, Popup Menus and Speedbuttons.

eg.,

You want to let the user of your application be able to set the view type of a TlistView component at run time so you assign the four values to a View Menu  on your main menu and you right the necessary code in each event handler of each menu item.  Later on you decide to add speedbuttons, and a popupmenu in the listview to do the same thing.

Do you rewrite all the code?  Redo all the work you have done (even if you cut and paste)?

No you assign each new speedbutton and popupmenu item in its onclick handler in the objectInspector the handler for the corresponding mainmenu item.

Voila, you've managed to save yourself a lot of hassle and time and made your code more efficient (although possibly slightly harder to follow - so comment well).

Hope this is of use.

Read any MAPI complient emails

Problem/Question/Abstract:

How can read emails from OutlookExpress, Outlook or Eudora from a Delphi program?

Answer:

We can read emails from any MAPI compliant email client using MAPI. The bad news is that we cannot read formatted email using simple MAPI, but only the plain text and attachments.

That�s because MAPI was created before HTML formatted emails were created. But MAPI can bevery useful anyway.

To run this program create a blank form (on IDE point to "File/Close all", then "File/New Application"), put a button on it, a Label (both on standard tab)and a RichEdit (on Win32 tab; I used a RichEdit because Memo can  only handle 32k of text).

unit Unit1;

{*****************************************************************
*       Simple MAPI sample                                      *
*       Source written by Rafael Cotta (rcotta.geo@yahoo.com)   *
*       July 26th, 2001                                         *
*****************************************************************}

// To run this sample, place on a blank form a TRichEdit, a TLabel
// and a TButton

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  hndMAPISession: Cardinal;
  v_CurrentMsgID: array[0..512] of char; // I�ll use long IDs here
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Initializing components and variables
  v_CurrentMsgID[0] := #0;

  hndMAPISession := 0;

  Button1.Caption := 'Read Next';
  RichEdit1.Lines.Clear;
  Label1.Caption := 'Subject : ';

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  dwRet: Cardinal;
  v_Out: array[0..512] of char;
  oMsg: PMapiMessage;
begin
  Label1.Caption := 'Retrieving... wait';

  if hndMAPISession = 0 then
  begin
    dwRet := MapiLogOn(
      Handle, // This window�s handle
      '', // If you want to use another profile that�s
      '', // not the default, set these two parameters
      MAPI_LOGON_UI, // Will prompt for logon if necessary
      0, // Reserve, must be 0
      @hndMAPISession);

    // An error occurred
    if (dwRet <> SUCCESS_SUCCESS) then
    begin
      MessageBox(Handle, PChar('Error ' + IntToHex(dwRet, 8) +
        ' while trying to logon'), PChar('Error'),
        MB_OK + MB_ICONERROR);
      Application.Terminate;
      Exit;
    end;
  end;

  dwRet := MapiFindNext(
    hndMAPISession,
    Handle,
    nil, // All messages
    @v_CurrentMsgID,
    MAPI_GUARANTEE_FIFO {sort by date; you can use "or MAPI_UNREAD_ONLY"},
    0,
    @v_Out // The messageId of message next to v_Current will be here
    );

  // Reached the end, so, going to first message
  if dwRet = MAPI_E_NO_MESSAGES then
  begin
    v_CurrentMsgID[0] := #0;

    MessageBox(Handle,
      PChar('Last message reached. Going to first one in InBox'),
      PChar('MAPI sample'),
      MB_OK + MB_ICONEXCLAMATION);

    dwRet := MapiFindNext(
      hndMAPISession,
      Handle,
      nil, // All messages
      @v_CurrentMsgID,
      MAPI_GUARANTEE_FIFO {sort by date; you can use "or MAPI_UNREAD_ONLY"},
      0,
      @v_Out // The messageId of message next to v_Current will be here
      );
  end;

  StrCopy(@v_CurrentMsgID, @v_Out);
  dwRet := MapiReadMail(
    hndMAPISession,
    Handle,
    @v_CurrentMsgID,
    MAPI_PEEK, // Won�t mark message as read
    0,
    oMsg
    );

  if dwRet = SUCCESS_SUCCESS then
  begin
    RichEdit1.SetTextBuf(oMsg.lpszNoteText);
    Label1.Caption := 'Subject : ' + StrPas(oMsg.lpszSubject);
  end;

  if Assigned(oMsg) then
    MapiFreeBuffer(oMsg);

end;

end.

Rotate the text in a StringGrid cell by 90�

Problem/Question/Abstract:

How to rotate the text in a StringGrid cell by 90�

Answer:

Solve 1:

uses
  {...} Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  end;

  {...}

implementation

{...}

// Display text vertically in StringGrid cells

procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect;
  Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var
  lf: TLogFont;
  tf: TFont;
begin
  // if the font is to big, resize it
  if (Size > Grid.ColWidths[ACol] div 2) then
    Size := Grid.ColWidths[ACol] div 2;
  with Grid.Canvas do
  begin
    // Replace the font
    Font.Name := Schriftart;
    Font.Size := Size;
    Font.Color := Color;
    tf := TFont.Create;
    try
      tf.Assign(Font);
      GetObject(tf.Handle, SizeOf(lf), @lf);
      lf.lfEscapement := 900;
      lf.lfOrientation := 0;
      tf.Handle := CreateFontIndirect(lf);
      Font.Assign(tf);
    finally
      tf.Free;
    end;
    // fill the rectangle
    FillRect(Rect);
    // Align text and write it
    if Alignment = taLeftJustify then
      TextRect(Rect, Rect.Left + 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taCenter then
      TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size +
        Size div 3, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taRightJustify then
      TextRect(Rect, Rect.Right - Size - Size div 2 - 2, Rect.Bottom -
        2, Grid.Cells[ACol, ARow]);
  end;
end;


Solve 2:

Display text vertically in StringGrid cells

procedure StringGridRotateTextOut2(Grid: TStringGrid; ARow, ACol: Integer; Rect:
  TRect;
  Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var
  NewFont, OldFont: Integer;
  FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
  // if the font is to big, resize it
  if (Size > Grid.ColWidths[ACol] div 2) then
    Size := Grid.ColWidths[ACol] div 2;
  with Grid.Canvas do
  begin
    // Set font
    if (fsBold in Font.Style) then
      FontStyle := FW_BOLD
    else
      FontStyle := FW_NORMAL;

    if (fsItalic in Font.Style) then
      FontItalic := 1
    else
      FontItalic := 0;

    if (fsUnderline in Font.Style) then
      FontUnderline := 1
    else
      FontUnderline := 0;

    if (fsStrikeOut in Font.Style) then
      FontStrikeout := 1
    else
      FontStrikeout := 0;

    Font.Color := Color;

    NewFont := CreateFont(Size, 0, 900, 0, FontStyle, FontItalic,
      FontUnderline, FontStrikeout, DEFAULT_CHARSET,
      OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
      DEFAULT_PITCH, PChar(Schriftart));

    OldFont := SelectObject(Handle, NewFont);
    // fill the rectangle
    FillRect(Rect);
    // Write text depending on the alignment
    if Alignment = taLeftJustify then
      TextRect(Rect, Rect.Left + 2, Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taCenter then
      TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size + Size div 3,
        Rect.Bottom - 2, Grid.Cells[ACol, ARow]);
    if Alignment = taRightJustify then
      TextRect(Rect, Rect.Right - Size - Size div 2 - 2, Rect.Bottom - 2,
        Grid.Cells[ACol, ARow]);

    // Recreate reference to the old font
    SelectObject(Handle, OldFont);
    // Recreate reference to the new font
    DeleteObject(NewFont);
  end;
end;

// Call the method in OnDrawCell

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
  // In the second column: Rotate Text by 90� and left align the text
  if ACol = 1 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL',
      12, clRed, taLeftJustify);

  // In the third column: Center the text
  if ACol = 2 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue,
      taCenter);

  // In all other columns third row: right align the text
  if ACol > 2 then
    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clGreen,
      taRightJustify);
end;

end.

Creating "Dynamic" Arrays

Problem/Question/Abstract:

Is it possible to re-size arrays at runtime?

Answer:

I came across an example of how to do one. The author is Ben Licht, who presents an age-old Pascal method of creating a dynamic array.

The trick is using a pointer to an array with a size of 1, then allocating memory for the pointer by multiplying the number of items you want in the array by the size of the array type.

Here's a sample unit I've adapted from his example:

{This unit demonstrates how to implement a dynArray}
unit U;

interface

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

type
  TResizeArr = array[0..0] of string;
  PResizeArr = ^TResizeArr;
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

procedure DefineDynArray(var h: THandle; {Handle to mem pointer}
  NumElements: LongInt; {Number of items in array}
  var PArr: PResizeArr); {Pointer to array struct}

procedure TestDynArray;

implementation
{$R *.DFM}

{============================================================================
Procedure that defines the dynarray. Note that the THandle and Pointer to
the array are passed by reference. This enables them to be defined outside
the scope of this procedure.
============================================================================}

procedure DefineDynArray(var h: THandle; {Handle to mem pointer}
  NumElements: LongInt; {Number of items in array}
  var PArr: PResizeArr); {Pointer to array struct}
begin

  {Allocate Windows Global Heap memory}
  h := GlobalAlloc(GMEM_FIXED, NumElements * sizeof(TResizeArr));
  PArr := GlobalLock(h);
end;

{============================================================================
Procedure that uses the DefineDynArray proc. This is pretty useless, but
provides a good example of how you can access the elements of the 'array'
once the array is defined.
============================================================================}

procedure TestDynArray;
var
  MyArray: PResizeArr;
  I: Integer;
  str: string;
  h: THandle;
begin
  str := '';
  DefineDynArray(h, 10, MyArray); {Define the 'array'}
  for I := 0 to 9 do
    MyArray^[I] := IntToStr(I);
  for I := 0 to 9 do
    str := str + MyArray^[I] + ',';
  ShowMessage(str);
  GlobalUnlock(h); {Must make a call to unlock the memory, then}
  GlobalFree(h); {free the memory and invalidate the handle}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TestDynArray;
end;

end.

This is a perfect example of one of those programming things that take hours to figure out, but turn out to be amazingly simple. But I should point out that it might just be simpler to use a TList, which does all of the above, but has methods to insert and delete items. It's only limited by the amount of memory you have.

How to register an ActiveX library at runtime and create the corresponding ActiveX control

Problem/Question/Abstract:

I want to write a client application which, when it starts, scans a given directory for ActiveX Form OCX's. If found, I want each ActiveForm to be loaded into the interface. This forms a modular plug-in style interface. Can anyone give me some advice on how to (register?) invoke and create an ActiveForm given just an OCX.

Answer:

The steps are:

Runtime registration of the ActiveX library
Runtime creation of the ActiveX control
Invoking methods


1. Registration of the ActiveX library


The code can be found in the source code of the TRegSrv project (Delphi4\demos\activex\tregsrv). The crucial steps are listed below (this is a procedure that I'm using myself. Could be that you will have to look for the units to include).


type
  TRegProc = function: HResult; stdcall;

procedure RegisterActiveXControl(Name: string; Extension: string);
{name is the name of the ActiveX control, Extension is 'ocx' or 'dll'}
var
  LibHandle: THandle;
  FileName: TFileName;
  RegProc: TRegProc;
begin
  {don't mind the path, use your own filename of your own ActiveX control}
  FileName := 'C:\Temp\PAx' + Name + '.' + Extension;
  {this line gets a handle to the ActiveX library}
  LibHandle := LoadLibrary(PChar(FileName));
  {prepares the registration}
  @RegProc := GetProcAddress(LibHandle, 'DllRegisterServer');
  if (not (@RegProc = nil)) then
  begin
    {this line executes the registration procedure, if the file is a correct ActiveX library}
    RegProc;
  end;
  {afterwards, the handle to the file is destroyed}
  FreeLibrary(LibHandle);
end;


2. Runtime creation of the corresponding ActiveX control

You need the following, in a procedure, function or method:


var
  AxControl: OleVariant;
begin
  AxControl := CreateOleObject(AxName);
  {in which AxName is something like 'AxLibraryName.AxControlName' (cf. 'Word.Basic'). You can find this AxName in the ProgID section of the registry}
  Result := AxControl.Execute(a, b); {Execute is a method of the AxControl}
end;

Convert from UNC notation to Drive letter?

Problem/Question/Abstract:

Convert from UNC notation to Drive letter?

Answer:

The function ExpandUNCFileName function converts a mapped path/file to UNC, but how can this process be reversed?

There is no simple function that would do the trick, you have to go through all existing 'remote' drives, look at their UNC name and compare them with the one you are interested in:


program P;

procedure TForm1.Button1Click(Sender: TObject);
const
  YOURUNCFILENAME = '\\ISS\VOL1\ISS\SHARE\';
var
  Drive: Char;
  Drlist: TStringList;
  Filist: TStringList;
  I: integer;
begin
  Drlist := TStringList.Create;
  Filist := TStringList.Create;
  for Drive := 'a' to 'z' do
    case GetDriveType(PChar(Drive + ':\')) of
      DRIVE_REMOTE:
        begin
          Filist.Add(expanduncfilename(Drive + ':\'));
          Drlist.Add(Drive)
        end
    end;
  {......}
  I := Filist.indexof(YOURUNCFILENAME);
  if I > -1 then
    ShowMessage(YOURUNCFILENAME + 'Mapped to drive ' + Drlist[I]);

  Drlist.Free;
  Filist.Free
end;

end.

Filling the screen with your form

Problem/Question/Abstract:

I'd like to resize a form and have it fill up the screen. But I don't want it to display over the Win95/WinNT taskbar. Is there a way to do this?

Answer:

I put the code in a component wrapper so all you have to do is drop the component onto any form, call the component's execute procedure in FormCreate, and voila! an instantly sized form that fits nicely within your screen, above the Taskbar.

For Non-Windows 95 users, your form will be sized to maximized, but will be still be FormStyle := wsNormal. Select the text below, put it in a file, save the file as SizeTask.pas, add into your component library, drop it into a form, and watch it go!

unit Sizetask;

interface

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

type
  TSizer = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure SetSize(MyForm: TForm);
  public
    { Public declarations }
    procedure Execute;
  end;

procedure Register;

implementation

procedure TSizer.Execute;
begin
  SetSize(TForm(Owner));
end;

procedure TSizer.SetSize(MyForm: TForm);
var
  TaskBarHandle: HWnd; { Handle to the Win95 Taskbar }
  TaskBarCoord: TRect; { Coordinates of the Win95 Taskbar }
  CxScreen, { Width of screen in pixels }
  CyScreen, { Height of screen in pixels }
  CxFullScreen, { Width of client area in pixels }
  CyFullScreen, { Height of client area in pixels }
  CyCaption: Integer; { Height of a window's title bar in pixels }
begin
  TaskBarHandle := FindWindow('Shell_TrayWnd', nil); { Get Win95 Taskbar handle }
  if TaskBarHandle = 0 then { We're running Win 3.x or WinNT w/o Win95
    shell, so just maximize }
    MyForm.WindowState := wsMaximized
  else { We're running Win95 or WinNT w/Win95 shell }
  begin
    MyForm.WindowState := wsNormal;
    GetWindowRect(TaskBarHandle, TaskBarCoord); { Get coordinates of Win95 Taskbar }
    CxScreen := GetSystemMetrics(SM_CXSCREEN);
      { Get various screen dimensions and set form's width/height }
    CyScreen := GetSystemMetrics(SM_CYSCREEN);
    CxFullScreen := GetSystemMetrics(SM_CXFULLSCREEN);
    CyFullScreen := GetSystemMetrics(SM_CYFULLSCREEN);
    CyCaption := GetSystemMetrics(SM_CYCAPTION);
    MyForm.Width := CxScreen - (CxScreen - CxFullScreen) + 1;
    MyForm.Height := CyScreen - (CyScreen - CyFullScreen) + CyCaption + 1;
    MyForm.Top := 0;
    MyForm.Left := 0;
    if (TaskBarCoord.Top = -2) and (TaskBarCoord.Left = -2) then
      {Taskbar on either top or left }
      if TaskBarCoord.Right > TaskBarCoord.Bottom then { Taskbar on top }
        MyForm.Top := TaskBarCoord.Bottom
      else { Taskbar on left }
        MyForm.Left := TaskBarCoord.Right;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSizer]);
end;

end.

How to create stereo wave files with accurate frequencies

Problem/Question/Abstract:

How do I generate low frequency audio < 1000 Hz with one frequency to the left channel and a slightly different frequency to the right? For example , a tone of 400 Hz is presented to the right ear and a tone of 410 Hz is presented simultaneously to the left ear ? I'm trying to write a small binaural beat test program. I understand the science but not how to generate the two tones in Windows.

Answer:

Assuming you want precise control over the waveforms, the best thing to do is to create a stereo .WAV file containing the desired data. Here's a function that will do that; you can adapt it to your needs (add MMSystem to your USES list):


procedure CreateSineWave(LeftFreq, RightFreq: Single; Duration: Cardinal; const FileName: string);
const
  BitsPerSample = 16;
  NumChannels = 2;
  SampleRate = 44100;
var
  ChunkSize: Integer;
  DataSize: Integer;
  Factor: Single;
  Format: TWaveFormatEx;
  FourCC: array[0..3] of Char;
  I: Integer;
  NumSamples: Integer;
  L: SmallInt;
  R: SmallInt;
  WaveStream: TFileStream;
begin
  WaveStream := TFileStream.Create(FileName, fmCreate);
  try
    FourCC := 'RIFF';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    NumSamples := (SampleRate * Duration) div 1000;
    DataSize := (BitsPerSample shr 3) * NumChannels * NumSamples;
    ChunkSize := DataSize + SizeOf(TWaveFormatEx) + 20;
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    FourCC := 'WAVE';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    FourCC := 'fmt ';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    ChunkSize := SizeOf(TWaveFormatEx);
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    with Format do
    begin
      wFormatTag := WAVE_FORMAT_PCM;
      nChannels := NumChannels;
      nSamplesPerSec := SampleRate;
      wBitsPerSample := BitsPerSample;
      nBlockAlign := nChannels * wBitsPerSample shr 3;
      nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
      cbSize := 0
    end;
    WaveStream.Write(Format, SizeOf(Format));
    FourCC := 'data';
    WaveStream.Write(FourCC, SizeOf(FourCC));
    ChunkSize := DataSize;
    WaveStream.Write(ChunkSize, SizeOf(ChunkSize));
    for I := 0 to 999 do
    begin
      Factor := Exp(-0.005 * (1000 - I));
      L := Round(Factor * 32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(Factor * 32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    for I := 1000 to NumSamples - 1001 do
    begin
      L := Round(32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    for I := NumSamples - 1000 to NumSamples - 1 do
    begin
      Factor := Exp(0.005 * (NumSamples - 1001 - I));
      L := Round(Factor * 32767 * Sin(2 * Pi * LeftFreq * I / SampleRate));
      R := Round(Factor * 32767 * Sin(2 * Pi * RightFreq * I / SampleRate));
      WaveStream.Write(L, SizeOf(L));
      WaveStream.Write(R, SizeOf(R))
    end;
    WaveStream.Position := 0;
  finally
    WaveStream.Free
  end
end;



So, for example, to create a two-second sample having a 400 Hz left channel and a 410 Hz right channel:


CreateSineWave(400.0, 410.0, 2000, 'foo.wav');


You can play the sound like this:


sndPlaySound('foo.wav', SND_SYNC);

Check which subitem of a TListView's ListItem was clicked (2)

Problem/Question/Abstract:

Is it possible to activate the click or double-click event for the subitems of a listview item? If yes, how can I do it?

Answer:

uses
  CommCtrl;

{$R *.dfm}

procedure TForm1.ListView1Click(Sender: TObject);
var
  pt: TPoint;
  item: TLIstItem;
  hittestinfo: TLVHitTestInfo;
begin
  pt := listview1.ScreenToClient(mouse.cursorpos);
  item := listview1.GetItemAt(pt.x, pt.y);
  if assigned(item) then
    memo1.Lines.add('Hit on item ' + item.Caption)
  else
  begin
    FillChar(hittestinfo, sizeof(hittestinfo), 0);
    hittestinfo.pt := pt;
    if - 1 <> listview1.perform(LVM_SUBITEMHITTEST, 0, lparam(@hittestinfo)) then
    begin
      memo1.lines.add(format('Item: %d (%s), subitem: %d (%s)', [hittestinfo.iItem,
        listview1.items[hittestinfo.iItem].caption, hittestinfo.iSubItem,
          listview1.items[hittestinfo.iItem].Subitems[hittestinfo.iSubItem - 1]]));

    end
    else
      memo1.lines.add('Not on item or subitem');
  end;
end;

Disabling an event handler once it has executed once

Problem/Question/Abstract:

Disabling an event handler once it has executed once

Answer:

Have you ever wanted to keep an event from firing once it has executed once? Simply set the event handler method to nil in the body of the method. For instance, let's say you want to disable an OnClick for a button once the user has pressed it. Here's the code to do that:

procedure Button1OnClick;
begin
  Button1.OnClick := nil;
end;