Color TDBGrid

Problem/Question/Abstract:

How to color TDBGrid

Answer:

Function to color a DBGrid (declared as private)

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  iValue: LongInt;
begin
  // color only the first field
  if (DataCol = 0) then
  begin
    // Check the field value and assign a color
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

How to check italian code for companies

Problem/Question/Abstract:

In Italy companies have a code for use with fiscal transactions. There's a checksum digit.
This function not only checks for its validity, but also retrieves some interesting information
from the code: the progressive number a company has in his state (provincia) and the country
that generated that code.

Answer:

const
  Provincie: array[0..102] of string =
  ('Torino', 'Vercelli', 'Novara', 'Cuneo', 'Asti',
    'Alessandria', 'Aosta', 'Imperia', 'Savona', 'Genova',
    'La Spezia', 'Varese', 'Como', 'Sondrio', 'Milano',
    'Bergamo', 'Brescia', 'Pavia', 'Cremona', 'Mantova',
    'Bolzano-Bozen', 'Trento', 'Verona', 'Vicenza', 'Belluno',
    'Treviso', 'Venezia', 'Padova', 'Rovigo', 'Udine',
    'Gorizia', 'Trieste', 'Piacenza', 'Parma', 'Reggio nell''Emilia',
    'Modena', 'Bologna', 'Ferrara', 'Ravenna', 'Forli''-Cesena',
    'Pesaro e Urbino', 'Ancona', 'Macerata', 'Ascoli Piceno', 'Massa-Carrara',
    'Lucca', 'Pistoia', 'Firenze', 'Livorno', 'Pisa',
    'Arezzo', 'Siena', 'Grosseto', 'Perugia', 'Terni',
    'Viterbo', 'Rieti', 'Roma', 'Latina', 'Frosinone',
    'Caserta', 'Benevento', 'Napoli', 'Avellino', 'Salerno',
    'L''Aquila', 'Teramo', 'Pescara', 'Chieti', 'Campobasso',
    'Foggia', 'Bari', 'Taranto', 'Brindisi', 'Lecce',
    'Potenza', 'Matera', 'Cosenza', 'Catanzaro', 'Reggio di Calabria',
    'Trapani', 'Palermo', 'Messina', 'Agrigento', 'Caltanissetta',
    'Enna', 'Catania', 'Ragusa', 'Siracusa', 'Sassari',
    'Nuoro', 'Cagliari', 'Pordenone', 'Isernia', 'Oristano',
    'Biella', 'Lecco', 'Lodi', 'Rimini', 'Prato',
    'Crotone', 'Vibo Valentia', 'Verbano-Cusio-Ossola'
    );

function PartitaIVA(code: string; var Progressive: integer; var Provincia: string):
  boolean;
  function ReduceSum(n: Integer): Integer;
  var
    i: Integer;
    s: string;
  begin
    s := inttostr(n);
    if (length(s) = 1) then
    begin
      result := n;
      exit;
    end;
    result := 0;
    for i := 1 to length(s) do
    begin
      result := result + strtointdef(s[i], 0);
    end;
  end;
  function ReduceNum(n: Integer): Integer;
  var
    s: string;
  begin
    result := n;
    s := inttostr(n);
    if (length(s) > 1) then
    begin
      result := strtointdef(s[length(s)], 0)
    end;
  end;
var
  i: Integer;
  c: Integer;
begin
  result := false;
  if (length(code) <> 11) then
  begin
    provincia := '11 numeric-characters needed!';
    raise exception.Create(provincia);
    exit;
  end;
  for i := 1 to 11 do
  begin
    if (not (code[i] in ['0'..'9'])) then
    begin
      provincia := '"' + code[i] + '" is not a numeric value!';
      raise exception.Create(provincia);
      exit;
    end;
  end;
  // Returns the town.
  i := strtointdef(copy(code, 8, 3), 0) - 1;
  if ((i < 0) or (i > 102)) then
  begin
    provincia := 'Value out of set!';
    raise exception.create(provincia);
    exit;
  end
  else
    provincia := provincie[i];
  // Returns the progressive number.
  progressive := strtointdef(copy(code, 1, 7), 0);
  // Calculates if is valid.
  c := 0;
  for i := 1 to 10 do
  begin
    if ((i mod 2) = 0) then
      inc(c, reducesum(strtointdef(code[i], 0) * 2))
    else
      inc(c, strtointdef(code[i], 0));
  end;
  result := ((10 - ReduceNum(c)) = strtointdef(code[11], -1));
end;

Text to GIF

Problem/Question/Abstract:

Text to GIF

Answer:

procedure TxtToGif(txt, FileName: string);
var
  temp: TBitmap;
  GIF: TGIFImage;
begin

  temp := TBitmap.Create;
  try
    temp.Height := 400;
    temp.Width := 60;
    temp.Transparent := True;
    temp.Canvas.Brush.Color := colFondo.ColorValue;
    temp.Canvas.Font.Name := Fuente.FontName;
    temp.Canvas.Font.Color := colFuente.ColorValue;
    temp.Canvas.TextOut(10, 10, txt);
    Imagen.Picture.Assign(nil);

    GIF := TGIFImage.Create;
    try
      // Convert the bitmap to a GIF
      GIF.Assign(Temp);
      // Save the GIF
      GIF.SaveToFile(FileName);
      // Display the GIF
      Imagen.Picture.Assign(GIF);
    finally
      GIF.Free;
    end;

  finally

    temp.Destroy;
  end;
end;

Boyer-Moore string searching

Problem/Question/Abstract:

Boyer-Moore string searching

Answer:

Solve 1:

unit BMSearch;

interface

type
{$IFDEF WINDOWS}
  size_t = Word;
{$ELSE}
  size_t = LongInt;
{$ENDIF}

type
  TTranslationTable = array[char] of char; { translation table }
  TSearchBM = class(TObject)
  private
    FTranslate: TTranslationTable; { translation table }
    FJumpTable: array[char] of Byte; { Jumping table }
    FShift_1: integer;
    FPattern: pchar;
    FPatternLen: size_t;
  public
    procedure Prepare(Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean);
    procedure PrepareStr(const Pattern: string; IgnoreCase: Boolean);
    function Search(Text: pchar; TextLen: size_t): pchar;
    function Pos(const S: string): integer;
  end;

implementation

uses
  SysUtils;

{Ignore Case Table Translation}

procedure CreateTranslationTable(var T: TTranslationTable; IgnoreCase: Boolean);
var
  c: char;
begin
  for c := #0 to #255 do
    T[c] := c;
  if not IgnoreCase then
    exit;
  for c := 'a' to 'z' do
    T[c] := UpCase(c);

  { Mapping all accented characters to their uppercase equivalent }

  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';

  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';
  T['�'] := 'A';

  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';

  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';
  T['�'] := 'E';

  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';

  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';
  T['�'] := 'I';

  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';

  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';
  T['�'] := 'O';

  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';

  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';
  T['�'] := 'U';

  T['�'] := '�';
end;

{Preparation of the jumping table}

procedure TSearchBM.Prepare(Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean);
var
  i: integer;
  c, lastc: char;
begin
  FPattern := Pattern;
  FPatternLen := PatternLen;
  if FPatternLen < 1 then
    FPatternLen := strlen(FPattern);
  {This algorythm is based on a character set of 256}
  if FPatternLen > 256 then
    exit;
  {1. Preparing translating table}
  CreateTranslationTable(FTranslate, IgnoreCase);
  {2. Preparing jumping table}
  for c := #0 to #255 do
    FJumpTable[c] := FPatternLen;
  for i := FPatternLen - 1 downto 0 do
  begin
    c := FTranslate[FPattern[i]];
    if FJumpTable[c] >= FPatternLen - 1 then
      FJumpTable[c] := FPatternLen - 1 - i;
  end;
  FShift_1 := FPatternLen - 1;
  lastc := FTranslate[Pattern[FPatternLen - 1]];
  for i := FPatternLen - 2 downto 0 do
    if FTranslate[FPattern[i]] = lastc then
    begin
      FShift_1 := FPatternLen - 1 - i;
      break;
    end;
  if FShift_1 = 0 then
    FShift_1 := 1;
end;

procedure TSearchBM.PrepareStr(const Pattern: string; IgnoreCase: Boolean);
var
  str: pchar;
begin
  if Pattern <> '' then
  begin
{$IFDEF Windows}
    str := @Pattern[1];
{$ELSE}
    str := pchar(Pattern);
{$ENDIF}
    Prepare(str, Length(Pattern), IgnoreCase);
  end;
end;

{Searching Last char & scanning right to left}

function TSearchBM.Search(Text: pchar; TextLen: size_t): pchar;
var
  shift, m1, j: integer;
  jumps: size_t;
begin
  result := nil;
  if FPatternLen > 256 then
    exit;
  if TextLen < 1 then
    TextLen := strlen(Text);
  m1 := FPatternLen - 1;
  shift := 0;
  jumps := 0;
  {Searching the last character}
  while jumps <= TextLen do
  begin
    Inc(Text, shift);
    shift := FJumpTable[FTranslate[Text^]];
    while shift <> 0 do
    begin
      Inc(jumps, shift);
      if jumps > TextLen then
        exit;
      Inc(Text, shift);
      shift := FJumpTable[FTranslate[Text^]];
    end;
    { Compare right to left FPatternLen - 1 characters }
    if jumps >= m1 then
    begin
      j := 0;
      while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do
      begin
        Inc(j);
        if j = FPatternLen then
        begin
          result := Text - m1;
          exit;
        end;
      end;
    end;
    shift := FShift_1;
    Inc(jumps, shift);
  end;
end;

function TSearchBM.Pos(const S: string): integer;
var
  str, p: pchar;
begin
  result := 0;
  if S <> '' then
  begin
{$IFDEF Windows}
    str := @S[1];
{$ELSE}
    str := pchar(S);
{$ENDIF}
    p := Search(str, Length(S));
    if p <> nil then
      result := 1 + p - str;
  end;
end;

end.


Solve 2:

Here's a demo program of the Boyer-Moore search algorithm. The basic idea is to first create a Boyer-Moore index table for the string you want to search for, and then call the BMsearch routine. Remember to turn-off Range Checking {$R-} in your finished program, otherwise the BMSearch will take 3-4 times longer than it should.


{Public-domain demo of Boyer-Moore search algorithm.
Guy McLoughlin - May 1, 1993.}

program DemoBMSearch;

{Boyer-Moore index table data definition}
type
  BMTable = array[0..127] of byte;

  {Create a Boyer-Moore index table to search with.}

procedure Create_BMTable(Pattern: string; var BMT: BMTable);
var
  Index: byte;
begin
  fillchar(BMT, sizeof(BMT), length(Pattern));
  for Index := 1 to length(Pattern) do
    BMT[ord(Pattern[Index])] := (length(Pattern) - Index)
end;

{Boyer-Moore Search function. Returns 0 if string is not found. Returns 65,535 if
BufferSize is too large, ie: greater than 65,520 bytes.}

function BMsearch(var Buffer; BuffSize: word; var BMT: BMTable; Pattern: string): word;
var
  Buffer2: array[1..65520] of char absolute Buffer;
  Index1, Index2, PatSize: word;
begin
  if (BuffSize > 65520) then
  begin
    BMsearch := $FFFF;
    exit
  end;
  PatSize := length(Pattern);
  Index1 := PatSize;
  Index2 := PatSize;
  repeat
    if (Buffer2[Index1] = Pattern[Index2]) then
    begin
      dec(Index1);
      dec(Index2)
    end
    else
    begin
      if (succ(PatSize - Index2) > (BMT[ord(Buffer2[Index1])])) then
        inc(Index1, succ(PatSize - Index2))
      else
        inc(Index1, BMT[ord(Buffer2[Index1])]);
      Index2 := PatSize
    end;
  until
    (Index2 < 1) or (Index1 > BuffSize);
  if (Index1 > BuffSize) then
    BMsearch := 0
  else
    BMsearch := succ(Index1)
end;

type
  arby_64K = array[1..65520] of byte;

var
  Index: word;
  st_Temp: string[10];
  Buffer: ^arby_64K;
  BMT: BMTable;

begin
  new(Buffer);
  fillchar(Buffer^, sizeof(Buffer^), 0);
  st_Temp := 'Gumby';
  move(st_Temp[1], Buffer^[65516], length(st_Temp));
  Create_BMTable(st_Temp, BMT);
  Index := BMSearch(Buffer^, sizeof(Buffer^), BMT, st_Temp);
  writeln(st_Temp, ' found at offset ', Index)
end.

Trap the OnEnter and OnLeave events

Problem/Question/Abstract:

This code shows how to get the OnEnter and OnLeave event from components without changing the component.

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FFocusControl: TControl;
    procedure ApplicationIdle(Sender: TObject; var Done: Boolean);
  public
    { Public declarations }
    procedure OnEnter(Sender: TObject);
    procedure OnExit(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FFocusControl := nil;
  Application.OnIdle := ApplicationIdle;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Application.OnIdle := nil;
end;

procedure TForm1.ApplicationIdle(Sender: TObject; var Done: Boolean);
var
  CurControl: TControl;
  P: TPoint;
begin
  GetCursorPos(P);
  CurControl := FindDragTarget(P, True);
  if FFocusControl <> CurControl then
  begin
    if FFocusControl <> nil then
      OnExit(FFocusControl);
    FFocusControl := CurControl;
    if FFocusControl <> nil then
      OnEnter(FFocusControl);
  end;
end;

procedure TForm1.OnEnter(Sender: TObject);
begin
  //OnEnter code
  if sender = Button1 then
  begin
    Label1.caption := 'Hello';
    Button1.Caption := 'Exit';
  end;
end;

procedure TForm1.OnExit(Sender: TObject);
begin
  //OnExit code
  if sender = Button1 then
  begin
    Label1.caption := 'Godbye';
    Button1.Caption := 'Enter';
  end;
end;

end.

How to check what type of component is the Sender

Problem/Question/Abstract:

The piece of code below is typical of some routines we have. This example only uses 2 component types but sometimes there could be 7 or 8 and then the code is really bad.

procedure TEN1FORM.myonEnter(Sender: TObject);
begin
  if Sender is TDBComboBox then
    enterstr := TDBComboBox(Sender).text
  else if Sender is TOVCDBPICTUREFIELD then
    enterstr := TOVCdbPICTUREFIELD(Sender).text;
end;

Answer:

Solve 1:

function CheckIsType(AObject: TObject; const ClassArray: array of TClass): Integer;
{Return an index indicative of a type match on the object, and array of types passed}
begin
  for Result := 0 to High(ClassArray) do
    if AObject is ClassArray[Result] then
      Exit;
  Result := -1;
end;

{ ... }
case CheckIsType(Sender, [TdbComboBox, TOVCDBPctureField, TSpeedButton, TEdit]) of
  0: { ... }; {TDBComboBox}
  1: { ... }; {TOVCDBPctureField}
  2: { ... }; {TSpeedButton}
  3: { ... }; {TEdit}
end;
{ ... }

I also use the following routine which does an exact type match:

function CheckType(AObject: TObject; const ClassArray: array of TClass): Integer;
var
  Index: Integer;
begin
  Result := -1;
  if Assigned(AObject) then
    for Index := 0 to High(ClassArray) do
      if AObject.ClassType = ClassArray[Index] then
      begin
        Result := Index;
        Exit;
      end;
end;


Solve 2:

Let me add one more way to tackle this: use run-time type information. Text is a published property so RTTI exists for it. So you can use the stuff in Unit TypInfo to access it.

uses
  TypInfo;

function GetStrProperty(anObj: TObject; const propname: string): string;
var
  PInfo: PPropInfo;
begin
  result := EmptyStr;
  PInfo := GetPropInfo(anObj.ClassInfo, propname);
  if PInfo <> nil then
    {found aproperty with this name, check if it has the correct type}
    if PInfo^.Proptype^.Kind in [tkString, tkLString] then
    begin
      {it has! Get the string value from theproperty}
      Result := GetStrProp(anObj, PInfo);
    end;
end;

Using this function your handler becomes

procedure TEN1FORM.myonEnter(Sender: TObject);
begin
  enterstr := GetStrProperty(sender, 'text');
  { ... }

How to limit the number of characters per line and the number of lines in a TMemo (2)

Problem/Question/Abstract:

Is there a way to place a maximum number of lines in a TMemo?

Answer:

procedure TForm1.Memo1Change(Sender: TObject);
var
  i: Integer;
  s: string;
begin
  i := Length(Memo1.Lines.Text);
  {Limit the number of lines to 3}
  if Memo1.Lines.Count > 3 then
  begin
    s := Memo1.Lines.Text;
    Delete(s, i, 1);
    {Remove line wrap}
    i := Length(s);
    while (Ord(s[i]) = 10) or (Ord(s[i]) = 13) do
    begin
      Delete(s, i, 1);
      i := Length(s);
    end;
    Memo1.Lines.Text := s;
    {posistion cursor at end of memo}
    Memo1.SelStart := Length(s);
    Memo1.SelLength := 0;
    ShowMessage('Over Max Lines');
  end;
end;

How to create a TProgressBar inside a TListView

Problem/Question/Abstract:

I would like to display a progress bar as a sub item in a TListView (vsReport mode). How can I do that?

Answer:

Well, you can in fact parent a live progressbar to a listview, you just have to do it at run-time. The sample below has timer that randomly steps the progress bars. The bar is added to the last column of the listview.

There are some gotchas here: the DisplayRect method of a listitem does not return the correct position unless the control is visible, thus the hack used at the top of the method to ensure this. And of course you will have to adjust the width and left bound of the progress bars if the user resizes columns. And you need to add new bars if the user can add items and destroy bars if the user can delete item.

procedure TForm1.FormCreate(Sender: TObject);
var
  pb: TProgressBar;
  r: TRect;
  i, k: Integer;
begin
  Show;
  Application.ProcessMessages;
  for i := 0 to listview1.items.count - 1 do
  begin
    r := listview1.items[i].DisplayRect(drBounds);
    {last column is to take progress bar}
    for k := 1 to listview1.columns.Count - 1 do
      r.left := r.left + listview1.columns[k - 1].Width;
    r.right := r.Left + listview1.columns[listview1.columns.Count - 1].Width;
    pb := TProgressBar.Create(self);
    pb.Parent := listview1;
    pb.BoundsRect := r;
    listview1.items[i].Data := pb;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i: Integer;
  pb: TProgressbar;
begin
  i := Random(listview1.items.count);
  pb := TProgressBar(listview1.Items[i].Data);
  if assigned(pb) then
    if pb.Position = pb.Max then
      pb.Position := 0
    else
      pb.StepBy(pb.Max div 10);
end;

Converting MS-Word DOC to RTF using OLE

Problem/Question/Abstract:

I want to load a Word document into a RitchText control

Answer:

Open a new Application and place:

  a button named Button3,
  a RitchText object named WordEditor
  and an OpenDialog component.

From now on, you can browse for any *.doc file and load it into the RitchText object.

NOTE: Format:=6 instructs Word to save the file as RTF. Extension is not enough.

Other File Formats:

Argument Format  
File Format
0
Normal (Word format)
1
Document Template
2
Text Only (extended characters saved in ANSI character set)
3
Text+Breaks (plain text with line breaks; extended characters saved in ANSI character set)
4
Text Only (PC-8) (extended characters saved in IBM PC character set)
5
Text+Breaks (PC-8) (text with line breaks; extended characters saved in IBM PC character set)
6
Rich-text format (RTF)



procedure TImport_Form.ToolButton3Click(Sender: TObject);
var
  WordApp: Variant;
begin
  if OpenDialog1.Execute then
  begin
    Edit1.Text := ExtractFileName(OpenDialog1.FileName);
    StatusBar1.SimpleText := OpenDialog1.FileName;
    WordApp := CreateOleObject('Word.Basic');
    if not VarIsEmpty(WordApp) then
    begin
      WordApp.FileOpen(OpenDialog1.FileName);
      WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format := 6);
      WordApp.AppClose;
      WordApp := Unassigned;
      WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');
    end
    else
      ShowMessage('Could not start MS Word');
  end;

end;

How to prevent word from opening password-protected files or resume wizard files and sometimes causing application to hang ?

The sollution is to add the folowing query before openning the document:

if WordApp.ActiveDocument.HasPassword = True then
  MsgBox("Password Protected");

You can even preset the password propery as:

WordApp.Password := 'mypassword";

NOTE: If the above code generates an "Undefined property: ActiveDocument" change the:

CreateOleObject('Word.Basic');

with

CreateOleObject('Word.Application');

How to detect a sound device

Problem/Question/Abstract:

Is there a way to detect a sound device (personally, I want to detect a sound card) to know if such a device is present on the computer my application is running?

Answer:

Solve 1:

{ ... }
if WaveOutGetNumDevs > 0 then
  ShowMessage('Wave-Device present')
else
  ShowMessage('No Wave-Device present');
{ ... }


Solve 2:

function IsSoundCardInstalled: Boolean;
type
  SCFunc = function: UInt; stdcall;
var
  LibInst: LongInt;
  EntryPoint: SCFunc;
begin
  Result := False;
  LibInst := LoadLibrary(PChar('winmm.dll'));
  try
    if LibInst <> 0 then
    begin
      EntryPoint := GetProcAddress(LibInst, 'waveOutGetNumDevs');
      if (EntryPoint <> 0) then
        Result := True;
    end;
  finally
    if (LibInst <> 0) then
      FreeLibrary(LibInst);
  end;
end;

Replace Text in Bookmarks in WORD

Problem/Question/Abstract:

How can I replace Text in Bookmarks in WORD?

Answer:

When Word is connected via OLE, you can use bookmarks to fill in text into an existing template or document.

The first step is connecting to WORD, either with an OLE-Object or in an OLE-Control.

The Server You connect to should be WORD.Document, not WORD.Application. With this, it is easier to control that You always word on the right Document.

Finding an Replacing a bookmark goes like that:

var
  Doc: Variant;
  Result: string;
  Bookmark: string;
  Startpos, Endpos: longint;
begin
  // You already are connected to a WORD.Document Object!
  //
  Result := 'anything';
  Bookmark := 'bookmark 20';
  // Replace the Text:
  Doc.Bookmarks.Items('bookmark 20').range.text := Result;
  // done this, You have lost the Bookmark, but integrated the Text
end;

Sending an email from Delphi with Outlook

Problem/Question/Abstract:

Sending an email from Delphi with Outlook

Answer:

Outlook can be easily controlled through OLE. Try the sample procedure SendOutlookMail() from below.

This does not work with Outlook Express.


program MailWithOutlook;

procedure SendOutlookMail;
const
  olMailItem = 0;
var
  Outlook: OleVariant;
  vMailItem: variant;
begin
  try
    Outlook := GetActiveOleObject('Outlook.Application');
  except
    Outlook := CreateOleObject('Outlook.Application');
  end;
  vMailItem := Outlook.CreateItem(olMailItem);
  vMailItem.Recipients.Add('dummy@hotmail.com');
  vMailItem.Subject := 'test email';
  vMailItem.Body := 'This is a test';
  vMailItem.Attachments.Add('C:\temp\sample.txt');
  vMailItem.Send;

  VarClear(Outlook);
end;

end.

How to save / load a ScanLine to / from a stream

Problem/Question/Abstract:

How to save / load a ScanLine to / from a stream

Answer:

I won't claim this is fastest in any way, but it shows how to write scanlines to a stream and then read the stream to fill in the scanlines.

Example of flipping a bitmap by writing to MemoryStream and loading second bitmap in flipped order.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  j: Integer;
  Bitmap1: TBitmap;
  Bitmap2: TBitmap;
  row: pByteArray;
  ScanlineBytes: Integer;
  Stream: TMemoryStream;
begin
  Bitmap1 := TBitmap.Create;
  try
    {Assume Image1 and Image2 are the same size}
    Bitmap1.Width := Image1.Width;
    Bitmap1.Height := Image1.Height;
    Bitmap1.PixelFormat := pf24bit;
    {Make something assymmetric in picture}
    Bitmap1.Canvas.Pen.Color := clRed;
    Bitmap1.Canvas.MoveTo(0, 0);
    Bitmap1.Canvas.LineTo(Bitmap1.Width, Bitmap1.Height);
    Bitmap1.Canvas.MoveTo(Bitmap1.Width div 2, 0);
    Bitmap1.Canvas.LineTo(0, Bitmap1.Height div 2);
    Image1.Picture.Graphic := Bitmap1;
    Stream := TMemoryStream.Create;
    try
      ScanlineBytes := ABS(Integer(Bitmap1.Scanline[1]) - Integer(Bitmap1.Scanline[0]));
      for j := 0 to Bitmap1.Height - 1 do
      begin
        row := Bitmap1.Scanline[j];
        Stream.Write(row[0], ScanlineBytes);
      end;
      Bitmap2 := TBitmap.Create;
      try
        Bitmap2.Width := Bitmap1.Width;
        Bitmap2.Height := Bitmap1.Height;
        Bitmap2.PixelFormat := pf24bit;
        {position stream pointer at beginning}
        Stream.Position := 0;
        {Flip bitmap by reading scanlines from stream and placing them in flipped row}
        for j := Bitmap2.Height - 1 downto 0 do
        begin
          row := Bitmap2.Scanline[j];
          Stream.Read(row[0], ScanlineBytes)
        end;
        Image2.Picture.Graphic := Bitmap2
      finally
        Bitmap2.Free
      end
    finally
      Stream.Free
    end
  finally
    Bitmap1.Free
  end;
end;

end.

Perform a file search including subdirectories

Problem/Question/Abstract:

How to perform a file search including subdirectories

Answer:

Solve 1:

Recursively scanning all drives:

{excerpt from form declaration, form has a listbox1 for the  results, a label1 for progress, a button2 to start the scan, an edit1 to get the search mask from, a button3 to stop the scan.}
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }

function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;

function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;

  function ScanDirectory(var path: string): Boolean;
  var
    SRec: TSearchRec;
    pathlen: Integer;
    res: Integer;
  begin
    label1.caption := path;
    pathlen := Length(path);
    { first pass, files }
    res := FindFirst(path + filemask, faAnyfile, SRec);
    if res = 0 then
    try
      while res = 0 do
      begin
        hitlist.Add(path + SRec.Name);
        res := FindNext(SRec);
      end;
    finally
      FindClose(SRec)
    end;
    Application.ProcessMessages;
    Result := not (FScanAborted or Application.Terminated);
    if not Result then
      Exit;
    {second pass, directories}
    res := FindFirst(path + ' *.* ', faDirectory, SRec);
    if res = 0 then
    try
      while (res = 0) and Result do
      begin
        if ((Srec.Attr and faDirectory) = faDirectory) and (Srec.name <> ' . ')
          and (Srec.name <> ' .. ') then
        begin
          path := path + SRec.name + '\';
          Result := ScanDirectory(path);
          SetLength(path, pathlen);
        end;
        res := FindNext(SRec);
      end;
    finally
      FindClose(SRec)
    end;
  end;

begin
  FScanAborted := False;
  Screen.Cursor := crHourglass;
  try
    Result := ScanDirectory(root);
  finally
    Screen.Cursor := crDefault
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  ch: Char;
  root: string;
begin
  root := 'C:\';
  for ch := 'A' to 'Z' do
  begin
    root[1] := ch;
    case GetDriveType(Pchar(root)) of
      DRIVE_FIXED, DRIVE_REMOTE:
        if not ScanDrive(root, edit1.text, listbox1.items) then
          Break;
    end;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin {aborts scan}
  fScanAborted := True;
end;


Solve 2:

procedure TFrmRecurseDirTree.RecurseDirTree(APath: string; AList: TStrings);
var
  searchRec: TSearchRec;
  thePath: string;
begin
  if (Length(thePath) > 0) then
    Exit;
  {Riffle through the subdirectories and find the file(s) there}
  thePath := APath;
  if (thePath[Length(thePath)] <> '\') then
    thePath := thePath + '\';
  if FindFirst(thePath + '*.*', faDirectory, searchRec) = 0 then
  try
    repeat
      if (searchRec.Attr and faDirectory > 1) and (searchRec.Name <> '.') and
        (searchRec.Name <> '..') then
      begin
        AList.Add(thePath + searchRec.Name);
        RecurseDirTree(thePath + searchRec.Name + '\', AList);
        Application.ProcessMessages;
      end;
    until
      FindNext(searchRec) <> 0;
  finally
    SysUtils.FindClose(searchRec);
  end;
end;


Solve 3:

Here is a procedure to scan for all bitmaps below the current directory and add them to a list. It can easily be modified to add all sub-directories to the list, just add "List.Add..." just before "ScanDirectory..." and delete the part that adds the bitmap filenames. Maybe it's better to change faAnyFile to faDirecory, but I am not sure if this will return all directories including hidden ones etc.

procedure TForm1.ScanDirectory(Path: string; List: TStringList; SubDirFlag: Boolean);
var
  SearchRec: TSearchRec;
  Ext: string;
begin
  if Path[Length(Path)] <> '\' then
    Path := Path + '\';
  if FindFirst(Path + '*.*', faAnyFile, SearchRec) = 0 then
  begin
    repeat
      if SearchRec.Attr = faDirectory then
      begin
        if SubDirFlag and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
          ScanDirectory(Path + SearchRec.Name, List, SubDirFlag);
      end
      else
      begin
        Ext := UpperCase(ExtractFileExt(SearchRec.Name));
        if (Ext = '.BMP') then
        begin
          List.Add(Path + SearchRec.Name);
        end;
      end;
    until
      FindNext(SearchRec) <> 0;
  end;
end;

Use it as follows:

ScanDirectory(GetCurrentDir, YourStringList, False);


Solve 4:

procedure TForm1.Button1Click(Sender: TObject);
var
  SearchRec: TSearchRec;
begin
  if FindFirst('c:\images\*.jpg', faAnyFile, SearchRec) = 0 then
  try
    repeat
      listbox1.items.add(searchrec.name);
    until
      Findnext(SearchRec) <> 0;
  finally
    FindClose(SearchRec);
  end;
end;

Note: if you are displaying many items, you will probably want to wrap the code within listbox1.items.BeginUpdate/EndUpdate.


Solve 5:

Searching for a file in a directory:

function FileExistsExt(const aPath, aFilename: string): Boolean;
var
  DSearchRec: TSearchRec;
begin
  Result := FileExists(IncludeTrailingPathDelimiter(aPath) + aFilename);
  if not Result then
  begin
    if FindFirst(APath + '\*', faDirectory, DSearchRec) = 0 then
    begin
      repeat
        if (DSearchRec.Name <> '.') and (DSearchRec.Name <> '..') then
          Result := FileExistsExt(IncludeTrailingPathDelimiter(aPath) +
                                         DSearchRec.Name, aFilename);
      until
        FindNext(DSearchRec) <> 0;
    end;
    FindClose(DSearchRec);
  end;
end;

Usage:

{ ... }
if FileExistsExt('C:', 'Testfile.dat') then
  { ... }


Solve 6:

The following function receives as parameters a file specification (like for example 'C:\My Documents\*.xls' or 'C:\*' if you want to search the entire hard disk) and optionally a set of attributes (exactly as Delphi's FindFirst function), and it returs a StringList with the full pathnames of the found files. You should free the StringList after using it.

interface

function FindFile(const filespec: TFileName; attributes: integer
  = faReadOnly or faHidden or faSysFile or faArchive): TStringList;

implementation

function FindFile(const filespec: TFileName;
  attributes: integer): TStringList;
var
  spec: string;
  list: TStringList;

  procedure RFindFile(const folder: TFileName);
  var
    SearchRec: TSearchRec;
  begin
    // Locate all matching files in the current
    // folder and add their names to the list
    if FindFirst(folder + spec, attributes, SearchRec) = 0 then
    begin
      try
        repeat
          if (SearchRec.Attr and faDirectory = 0) or
            (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
            list.Add(folder + SearchRec.Name);
        until FindNext(SearchRec) <> 0;
      except
        FindClose(SearchRec);
        raise;
      end;
      FindClose(SearchRec);
    end;
    // Now search the subfolders
    if FindFirst(folder + '*', attributes
      or faDirectory, SearchRec) = 0 then
    begin
      try
        repeat
          if ((SearchRec.Attr and faDirectory) <> 0) and
            (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
            RFindFile(folder + SearchRec.Name + '\');
        until FindNext(SearchRec) <> 0;
      except
        FindClose(SearchRec);
        raise;
      end;
      FindClose(SearchRec);
    end;
  end; // procedure RFindFile inside of FindFile

begin // function FindFile
  list := TStringList.Create;
  try
    spec := ExtractFileName(filespec);
    RFindFile(ExtractFilePath(filespec));
    Result := list;
  except
    list.Free;
    raise;
  end;
end;

Sample call

You can try this function placing a ListBox and a button on a form and adding this code to the OnClick event of the button:

procedure TForm1.Button1Click(Sender: TObject);
var
  list: TStringList;
begin
  list := FindFile('C:\Delphi\*.pas');
  ListBox1.Items.Assign(list);
  list.Free;
end;


Solve 7:

I thought if there was a way to create a function that does not recursively call itself to list all the files in the harddisk, so that there might be some improvement in speed, other than making the function more complex there were no speed improvements. Here is the code of the function any way.

type
  PRecInfo = ^TRecInfo;
  Trecinfo = record
    prev: PRecInfo;
    fpathname: string;
    srchrec: Tsearchrec;
  end;

function TForm1.RecurseDirectory1(fname: string): tstringlist;
var
  f1, f2: Tsearchrec;
  p1, tmp: PRecInfo;
  fwc: string;
  fpath: string;
  fbroke1, fbroke2: boolean;
begin
  result := tstringlist.create;
  fpath := extractfilepath(fname);
  fwc := extractfilename(fname);
  new(p1);
  p1.fpathname := fpath;
  p1.prev := nil;
  fbroke1 := false;
  fbroke2 := false;
  while (p1 <> nil) do
  begin
    if (fbroke1 = false) then
      if (fbroke2 = false) then
      begin
        if (findfirst(fpath + '*', faAnyfile, f1) <> 0) then
          break;
      end
      else if (findnext(f1) <> 0) then
      begin
        repeat
          findclose(f1);
          if (p1 = nil) then
            break;
          fpath := p1.fpathname;
          f1 := p1.srchrec;
          tmp := p1.prev;
          dispose(p1);
          p1 := tmp;
        until (findnext(f1) = 0);
        if (p1 = nil) then
          break;
      end;
    if ((f1.Name <> '.') and (f1.name <> '..') and ((f1.Attr and fadirectory) =
      fadirectory)) then
    begin
      fbroke1 := false;
      new(tmp);
      with tmp^ do
      begin
        fpathname := fpath;
        srchrec.Time := f1.time;
        srchrec.Size := f1.size;
        srchrec.Attr := f1.attr;
        srchrec.Name := f1.name;
        srchrec.ExcludeAttr := f1.excludeattr;
        srchrec.FindHandle := f1.findhandle;
        srchrec.FindData := f1.FindData;
      end;
      tmp.prev := p1;
      p1 := tmp;
      fpath := p1.fpathname + f1.name + '\';
      if findfirst(fpath + fwc, faAnyfile, f2) = 0 then
      begin
        result.add(fpath + f2.Name);
        while (findnext(f2) = 0) do
          result.add(fpath + f2.Name);
        findclose(f2);
      end;
      fbroke2 := false;
    end
    else
    begin
      if (findnext(f1) <> 0) then
      begin
        findclose(f1);
        fpath := p1.fpathname;
        f1 := p1.srchrec;
        fbroke1 := false;
        fbroke2 := true;
        tmp := p1.prev;
        dispose(p1);
        p1 := tmp;
      end
      else
      begin
        fbroke1 := true;
        fbroke2 := false;
      end;
    end;
  end;
  fpath := extractfilepath(fname);
  if findfirst(fname, faAnyfile, f1) = 0 then
  begin
    result.add(fpath + f2.Name);
    while (findnext(f1) = 0) do
      result.add(fpath + f2.Name);
    findclose(f1);
  end;
end;