Save and load a TTreeView to / from a stream

Problem/Question/Abstract:

I'd like to use the TreeView component for hierarchizing some data. For this, I need to add to every node an integer property which will refer to the primary key field of an associated database. Alas, I fear that the TreeView "SaveToFile" and "LoadFromFile" methods save/ load only the Text property! Then, how can I save and load this integer property (and by the way, the imageindex) for every node?

Answer:

By writing your own save and load routines. Untested! Don't forget to rewind the stream before loading when you test this code.

procedure SaveTreeviewToStream(tv: TTreeview; S: TStream);
var
  writer: TWriter;
  node: TTreeNode;
begin
  Assert(Assigned(tv));
  Assert(Assigned(S));
  writer := TWriter.Create(S, 4096);
  try
    node := tv.Items[0];
    writer.WriteListBegin;
    while node <> nil do
    begin
      writer.WriteInteger(node.level);
      writer.WriteString(node.Text);
      writer.WriteInteger(node.Imageindex);
      writer.WriteInteger(Integer(node.data));
      node := node.GetNext;
    end;
    writer.WriteListEnd;
    writer.FlushBuffer;
  finally
    writer.Free;
  end;
end;

procedure LoadTreeviewFromStream(tv: TTreeview; S: TStream);
var
  reader: TReader;
  node: TTreeNode;
  level: Integer;
begin
  Assert(Assigned(tv));
  Assert(Assigned(S));
  tv.Items.BeginUpdate;
  try
    tv.Items.Clear;
    reader := TReader.Create(S, 4096);
    try
      node := nil;
      reader.ReadListBegin;
      while not Reader.EndOfList do
      begin
        level := reader.ReadInteger;
        if node = nil then
          {create root node, ignore its level}
          node := tv.Items.Add(nil, '')
        else
        begin
          if level = node.level then
            node := tv.Items.Add(node, '')
          else if level > node.level then
            node := tv.Items.AddChild(node, '')
          else
          begin
            while Assigned(node) and (level < node.level) do
              node := node.Parent;
            node := tv.Items.Add(node, '');
          end;
        end;
        node.Text := Reader.ReadString;
        node.ImageIndex := Reader.ReadInteger;
        node.Data := Pointer(Reader.ReadInteger);
      end;
      reader.ReadListEnd;
    finally
      reader.Free;
    end;
  finally
    tv.items.Endupdate;
  end;
end;

I'd rather suggest to use the data pointer as a pointer to a real object, not as integer (in the SaveTreeviewToStream procedure). You could add more complex info inside this object, like type information, or even the data objects itself. Type information is essential if your treeview browses through different tables of your database.

Count the number of Mondays between two given dates

Problem/Question/Abstract:

How to count the number of Mondays between two given dates

Answer:

Solve 1:

function NumMondays(dt1, dt2: TDateTime): integer;
var
  Date1, Date2, DateSpan: integer;
  Weekday1, DaysInStub: integer;
  MondayInStub: Boolean;
begin
  {Make sure date 1 is smaller than date 2}
  Date1 := MinIntValue([Trunc(dt1), Trunc(dt2)]);
  Date2 := MaxIntValue([Trunc(dt1), Trunc(dt2)]);
  {First approximation: complete weeks}
  DateSpan := Date2 - Date1 + 1;
  result := DateSpan div 7;
  {Now check if there's a Monday in the stub}
  MondayInStub := false;
  DaysInStub := DateSpan mod 7;
  Weekday1 := DayOfWeek(Date1);
  case Weekday1 of
    {Sunday}
    1: MondayInStub := DaysInStub > 0;
    {Monday}
    2: MondayInStub := true; {Starts and ends with Monday}
    {Sunday}
    3..7: MondayInStub := (Weekday1 + DaysInStub > 9 {2+7});
  end;
  if MondayInStub then
    inc(result);
end;


Solve 2:

Something like this should do the trick. I included the variable setup and display of results from my little test so that it will be obvious what I did.

procedure TForm1.Button1Click(Sender: TObject);
var
  cnt: integer;
  StartDate, EndDate: TDate;
begin
  cnt := 0;
  StartDate := StrToDate('4/21/2003');
  EndDate := StrToDate('5/30/2003');
  {Actual Monday counting}
  repeat
    if DayOfWeek(StartDate) = 2 then {2 = Monday (Sun = 1 .. Sat = 7) }
      inc(cnt);
    StartDate := StartDate + 1;
  until
    StartDate = EndDate;
  label1.Caption := IntToStr(cnt);
end;

How to test for resource depletion

Problem/Question/Abstract:

I have a process that, under some conditions, can deplete a machine's resources. Is there a way for my application to check how close it is to that point?

Answer:

unit Sysresources;

interface

uses
  Windows, Sysutils;

const
  GFSR_SYSTEMRESOURCES = 0;
  GFSR_GDIRESOURCES = 1;
  GFSR_USERRESOURCES = 2;

function GetSystemResources(typ: Word): Integer;

implementation

var
  hDll: HMODULE;
  pProc: function(typ: word): Integer stdcall;

function GetSystemResources(typ: word): Integer;
begin
  result := pProc(typ);
end;

function InternalGetSystemresources(typ: Word): Integer; stdcall;
begin
  result := -1;
end;

initialization
  pProc := InternalGetSystemresources;
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
  begin
    hdll := LoadLibrary('rsrc32.dll');
    if hdll <> 0 then
    begin
      @pProc := getProcAddress(hdll, '_MyGetFreeSystemResources32@4');
      if @pProc = nil then
        pProc := InternalGetSystemresources;
    end;
  end;

finalization
  if hDLL <> 0 then
    FreeLibrary(hdll);
end.

Right-align a menu item (2)

Problem/Question/Abstract:

I want to write a TMenu component where all items and sub menus are right justified.

Answer:

You can change the item's justification, if you add the MFT_RIGHTJUSTIFY constant to the item's type (fType member of the TMenuItemInfo structure). You can do it in the main menu's OnChange event handler. Here's an example:

procedure TForm1.MainMenu1Change(Sender: TObject; Source: TMenuItem; Rebuild:
  Boolean);
var
  XHandle: HMENU;
  XMenuItemInfo: TMenuItemInfo;
  XBuffer: array[0..79] of Char;
begin
  XHandle := TMainMenu(Sender).Handle;
  XMenuItemInfo.cbSize := 44;
  XMenuItemInfo.fMask := MIIM_TYPE;
  XMenuItemInfo.dwTypeData := XBuffer;
  XMenuItemInfo.cch := SizeOf(XBuffer);
  if GetMenuItemInfo(XHandle, 0, true, XMenuItemInfo) then
  begin
    XMenuItemInfo.fType := XMenuItemInfo.fType or MFT_RIGHTORDER or MFT_RIGHTJUSTIFY;
    XMenuItemInfo.fMask := MIIM_TYPE;
    SetMenuItemInfo(XHandle, 0, true, XMenuItemInfo);
  end;
end;

Attach a TComboBox to the column of a TStringGrid

Problem/Question/Abstract:

How to attach a TComboBox to the column of a TStringGrid

Answer:

Solve 1:

Here is one way to do it, using a single combobox that moves from cell to cell as required.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    ComboBox1: TComboBox;
    procedure ComboBox1Exit(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var
      CanSelect: Boolean);
  private
    { Private declarations }
    procedure CMDialogKey(var msg: TCMDialogKey); message CM_DIALOGKEY;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
  if Activecontrol = ComboBox1 then
  begin
    if msg.CharCode = VK_TAB then
    begin
      {set focus back to the grid and pass the tab key to it}
      stringgrid1.setfocus;
      stringgrid1.perform(WM_KEYDOWN, msg.charcode, msg.keydata);
      {swallow this message}
      msg.result := 1;
      Exit;
    end;
  end;
  inherited;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
  with sender as TComboBox do
  begin
    hide;
    if itemindex >= 0 then
      with stringgrid1 do
        cells[col, row] := items[itemindex];
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ComboBox1.visible := false;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
var
  R: TRect;
  org: TPoint;
begin
  with Sender as TStringGrid do
    if (ACol = 2) and (ARow >= FixedRows) then
    begin
      {entered the column associated to the combobox}
      {get grid out of selection mode}
      perform(WM_CANCELMODE, 0, 0);
      {position the control on top of the cell}
      R := CellRect(Acol, Arow);
      org := Self.ScreenToClient(ClientToScreen(R.topleft));
      with ComboBox1 do
      begin
        setbounds(org.X, org.Y, r.right - r.left, height);
        itemindex := Items.IndexOf(Cells[acol, arow]);
        Show;
        BringTofront;
        {focus the combobox and drop down the list}
        SetFocus;
        DroppedDown := true;
      end;
    end;
end;

end.


Solve 2:

unit GridCombo;

interface

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

type
  TFrmGridCombo = class(TForm)
    StringGrid1: TStringGrid;
    BtnSave: TButton;
    StringGrid2: TStringGrid;
    BtnLoad: TButton;
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var
      CanSelect: Boolean);
  private
    FCBox: TComboBox;
    procedure ComboClick(Sender: TObject);
  public
    { Public declarations }
  end;

var
  FrmGridCombo: TFrmGridCombo;

implementation

{$R *.DFM}

procedure TFrmGridCombo.StringGrid1SelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
var
  thisRect: TRect; {Notational clarity.}
begin
  if (ARow = 1) and (ACol <> 0) then
  begin
    if Assigned(FCBox) then
      FCBox.Free;
    FCBox := TComboBox.Create(self);
    FCBox.Parent := self;
    thisRect := StringGrid1.CellRect(ACol, ARow);
    FCBox.Left := thisRect.Left + StringGrid1.Left + 2;
    FCBox.Top := thisRect.Top + StringGrid1.Top + 2;
    FCBox.Width := (thisRect.Right - thisRect.Left);
    FCBox.Height := (thisRect.Bottom - thisRect.Top);
    FCBox.Items.LoadFromFile('File2.Txt');
    FCBox.SetFocus;
    FCBox.OnClick := ComboClick;
  end
  else if Assigned(FCBox) then
  begin
    FCBox.Free;
    FCBox := nil;
  end;
end;

procedure TFrmGridCombo.ComboClick(Sender: TObject);
begin
  if Sender is TComboBox then
    StringGrid1.Cells[StringGrid1.Col, StringGrid1.Row] := TComboBox(Sender).Text;
end;

end.

How to convert an integer value to a Roman Numeral representation

Problem/Question/Abstract:

How to convert an integer value to a Roman Numeral representation

Answer:

Converts an integer value to a string containing a roman numeric code ("XVII"):

{Parameters:   - Num: Integer to convert.
Return Value:  - Roman numerical representation of the passed integer value.
History:  12/7/99 "Philippe Ranger" (PhilippeRanger@compuserve.com)}

function IntToRoman(num: Cardinal): string; {returns num in capital roman digits}
const
  Nvals = 13;
  vals: array[1..Nvals] of word = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900,
    1000);
  roms: array[1..Nvals] of string[2] = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC',
    'C', 'CD', 'D', 'CM', 'M');
var
  b: 1..Nvals;
begin
  result := '';
  b := Nvals;
  while num > 0 do
  begin
    while vals[b] > num do
      dec(b);
    dec(num, vals[b]);
    result := result + roms[b]
  end;
end;

How to keep your application focused at all times

Problem/Question/Abstract:

I want my application to keep focus at any time. So, if someone clicks another window, I want my application to retrieve back focus.

Answer:

Solve 1:

To get your application into the foreground in W98, ME, W2K and XP, instead of using SetForegroundWindow, try this:


procedure ShowMe;
var
  Th1, Th2: Cardinal;
begin
  Th1 := GetCurrentThreadId;
  Th2 := GetWindowThreadProcessId(GetForegroundWindow, nil);
  AttachThreadInput(Th2, Th1, true);
  try
    SetForegroundWindow(Application.Handle);
  finally
    AttachThreadInput(Th2, Th1, false);
  end;
end;


Solve 2:

As well as the SetForegroundWindow (if you are using Win9X and not WinNT/2000), you could trick the system that your application is a running screensaver. In this case it will not loose focus, for screensavers by design maintain focus.

{ ... }
var
  old: Bool;
begin
  {Make it a Screensaver}
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(True), @old, 0);

or

{Make it not a Screensaver}
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(False), @old, 0);

MS-SQL : connection is in use by another statement

Problem/Question/Abstract:

MS-SQL : connection is in use by another statement

Answer:

When porting a larger database application (130k LOC) that worked fine with Oracle and InterBase to MS-SQL (6.5), I frequently got the error message 'connection is in use by another statement'.

At first, creating a new TDatabase for each TTable/ TQuery seemed to be necessary.

Then I found what was 'wrong' (not really wrong.. :-)

To speed up some of my queries, I had set the property Unidirectional to true. Delphi creates for such queries only one cursor (versus two for bidirectional queries or TTables). After removing the assignments of Unidirectional := true the error message disappeared and everything worked fine.

The following code resulted in the exception 'connection is in use by another statement':

// dataBaseNameS : string  is the name of the alias (MS-SQL 6.5)
begin
  Query1 := TQuery.Create(Application);
  with Query1 do
  begin
    DatabaseName := dataBaseNameS;
    SQL.Text := 'SELECT * FROM ABLESTOP';
    // the exception disappears if the following is removed
    Unidirectional := True;
    Open;
  end;
  ShowMessage('ok')

  Table1 := TTable.Create(Self);
  with Table1 do
  begin
    DatabaseName := dataBaseNameS;
    TableName := 'COMPONENT_PLAN';
    UpdateMode := upWhereKeyOnly;
    Open
  end;

  Table1.Insert;
  Table1.FieldByName('PARTNO').AsString := IntToStr(GetTickCount);
  Table1.FieldByName('ID').AsString := 'WWxx';
  Table1.FieldByName('VERSION').AsInteger := 1;
  // the exception will occurr in the next statement:
  //     "Connection is in use by another statement"
  Table1.Post;
end;

Play Musical Notes via PC Speaker Class

Problem/Question/Abstract:

Play Musical Notes via PC Speaker Class

Answer:

This is a simple class that plays a formatted musical string. It is reminiscent of the old GWBASIC days whereby one could play a string of notes via the PC speaker. I know that WAV and MIDI files are available in todays technology, but sometimes one does not need all that overhead. The class is useful for certain types of alarms (specially if the user has his sound card volume muted) or simple "Cell Phone" like jingles. The trick of the matter in Delphi is that the standard DELPHI implementation of BEEP takes no arguments and has only one sound. However the WIN API BEEP() takes two arguments.

ie.

BOOL Beep(
          DWORD dwFreq,     // sound frequency, in hertz
          DWORD dwDuration  // sound duration, in milliseconds
         );


Parameters

dwFreq

   Windows NT:
   Specifies the frequency, in hertz, of the sound. This parameter   must be in the range 37 through 32,767 (0x25        through 0x7FFF).

   Windows 95:
   The parameter is ignored.

dwDuration

   Windows NT:
   Specifies the duration, in milliseconds, of the sound.

   Windows 95:
   The parameter is ignored.

As can be seen it appears that BEEP() is NOT supported on WIN95, but is OK from there upwards. (I have not tested it on WIN95, but assume you will just get a monotone ???? - anyone for comment)

It is easily called by prefixing the unit
ie. Windows.Beep(Freq,Duration)

The format of the "Music String" is a comma delimited (",<" terminated) string in the following formats. (The string is CASE-INSENSITIVE and [] means optional with defaults).

A..G[+ or -][0..5][/BEATS] and

@[/BEATS]

Where A..G   is the Note to be played.
      + or - is optional Sharp or Flat designator respectively. (default is normal NULL)
      0..5   is optional Octave range (default = 1)
      /BEATS is number of 100ms to hold the note (default = 1)

where @      is a musical pause
      /BEATS is the number of beats to pause for (default = 1)

where ,<     is the END OF STRING terminator.

Properties:
DefaultOctave                         : Used if no 0..5 designator specified in format. (System Default = 1)  
BetweenNotesPause         : Use to set number MS gap between notes (faster or slower default = 100ms)

Simple Example:

procedure TForm1.Button3Click(Sender: TObject);
var
  Organ: TMusicPlayer;
begin
  Organ := TMusicPlayer.Create;
  Organ.Play('A,C,C+,D/3,C,A,C,A,@,F,D/4,<');
  Organ.Play('A,A3/2,G4,G/3,@/2,D-0/4,<');
  Organ.Free;
end;

Any enhancements or additional ideas welcome. Happy jingeling.

unit Music;
interface

uses Windows, SysUtils;

// ===========================================================================
// Mike Heydon May 2002
// Simple Music Player Class Win98/2000 (Win95 not supported)
// Implements Notes A,A#/Bb,C,C#/Db,D,D#,Eb,E,F,F#/Gb,G,G#/Ab
// Caters for Octaves 0..5
// In Between Note Pause setable.
// Defailt Octave setable.
//
// Based on Frequency Matrix
//
//         Octave0   Octave1   Octave2   Octave3   Octave4   Octave5
// A       55.000    110.000   220.000   440.000   880.000   1760.000
// A#/Bb   58.270    116.541   233.082   466.164   932.328   1864.655
// B       61.735    123.471   246.942   493.883   987.767   1975.533
// C       65.406    130.813   261.626   523.251   1046.502  2093.005
// C#/Db   69.296    138.591   277.183   554.365   1108.731  2217.461
// D       73.416    146.832   293.665   587.330   1174.659  2349.318
// D#/Eb   77.782    155.563   311.127   622.254   1244.508  2489.016
// E       82.407    164.814   329.628   659.255   1318.510  2637.020
// F       87.307    174.614   349.228   698.456   1396.913  2793.826
// F#/Gb   92.499    184.997   369.994   739.989   1479.978  2959.955
// G       97.999    195.998   391.995   783.991   1567.982  3135.963
// G#/Ab   103.826   207.652   415.305   830.609   1661.219  3322.438
//
// @ = Pause
// < = End of Music String Marker
//
// ===========================================================================

type
  TOctaveNumber = 0..5;
  TNoteNumber = -1..11;

  TMusicPlayer = class(TObject)
  private
    Octave,
      FDefaultOctave: TOctaveNumber;
    NoteIdx: TNoteNumber;
    FBetweenNotesPause,
      Duration: integer;
  protected
    function ParseNextNote(var MS: string): boolean;
  public
    constructor Create;
    procedure Play(const MusicString: string);
    property DefaultOctave: TOctaveNumber read FDefaultOctave
      write FDefaultOctave;
    property BetweenNotesPause: integer read FBetweenNotesPause
      write FBetweenNotesPause;
  end;

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

const
  MAXSTRING = 2048; // ASCIIZ String max length

  MHERTZ: array[0..11, 0..5] of integer = // Array of Note MHertz
  ((55, 110, 220, 440, 880, 1760), // A
    (58, 117, 233, 466, 932, 1865), // A+ B-
    (62, 123, 247, 494, 988, 1976), // B
    (65, 131, 262, 523, 1047, 2093), // C
    (69, 139, 277, 554, 1109, 2217), // C+ D-
    (73, 147, 294, 587, 1175, 2349), // D
    (78, 156, 311, 622, 1245, 2489), // D+ E-
    (82, 165, 330, 659, 1319, 2637), // E
    (87, 1745, 349, 698, 1397, 2794), // F
    (92, 185, 370, 740, 1480, 2960), // F+ G-
    (98, 196, 392, 784, 1568, 3136), // G
    (105, 208, 415, 831, 1661, 3322) // G+ A-
    );

  // =======================================
  // Create the object and set defaults
  // =======================================

constructor TMusicPlayer.Create;
begin
  FDefaultOctave := 1;
  FBetweenNotesPause := 100;
end;

// ===========================================================
// Parse the next note and set Octave,NoteIdx and Duration
// ===========================================================

function TMusicPlayer.ParseNextNote(var MS: string): boolean;
var
  NS: string; // Note String
  Beats,
    CommaPos: integer;
  Retvar: boolean;
begin
  Retvar := false; // Assume Error Condition
  Beats := 1;
  Duration := 0;
  NoteIdx := 0;
  Octave := FDefaultOctave;
  CommaPos := pos(',', MS);

  if (CommaPos > 0) then
  begin
    NS := trim(copy(MS, 1, CommaPos - 1)); // Next Note info
    MS := copy(MS, CommaPos + 1, MAXSTRING); // Remove note from music string

    if (length(NS) >= 1) and (NS[1] in ['@'..'G']) then
    begin
      Retvar := true; // Valid Note - set return type true

      // Resolve NoteIdx
      NoteIdx := byte(NS[1]) - 65; // Map 'A'..'G' into 0..11 or -1
      NS := copy(NS, 2, MAXSTRING); // Remove the Main Note ID

      // Handle the @ Pause first
      if NoteIdx = -1 then
      begin
        if (length(NS) >= 1) and (NS[1] = '/') then
          Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);
        Sleep(100 * Beats);
        Retvar := false; // Nothing to play
        NS := ''; // Stop further processing
      end;

      // Resolve Sharp or Flast
      if (length(NS) >= 1) and (NS[1] in ['+', '-']) then
      begin
        if NS[1] = '+' then // # Sharp
          inc(NoteIdx)
        else if NS[1] = '-' then // b Flat
          dec(NoteIdx);

        if NoteIdx = -1 then
          NoteIdx := 11; // Roll A Flat to G Sharp
        NS := copy(NS, 2, MAXSTRING); // Remove Flat/Sharp ID
      end;

      // Resolve Octave Number - Default := FDefaultOctave
      if (length(NS) >= 1) and (NS[1] in ['0'..'5']) then
      begin
        Octave := byte(NS[1]) - 48; // map '0'..'5' to 0..5 decimal
        NS := copy(NS, 2, MAXSTRING); // Remove Octave Number
      end;

      // Resolve Number of Beats - Default = 1
      if (length(NS) >= 1) and (NS[1] = '/') then
        Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);

      Duration := 100 * Beats;
    end;
  end
  else
    MS := ''; // Signal end of music string

  Result := Retvar;
end;

// ===================================
// Play the passed music string
// ===================================

procedure TMusicPlayer.Play(const MusicString: string);
var
  MS: string; // Music String
begin
  MS := trim(UpperCase(MusicString));

  while (MS <> '') do
  begin
    if ParseNextNote(MS) then
    begin
      Windows.Beep(MHERTZ[NoteIdx, Octave], Duration);
      Sleep(FBetweenNotesPause);
    end;
  end;
end;

end.

How to display hints on the status bar

Problem/Question/Abstract:

How to display hints on the status bar

Answer:

The following unit demonstrates displaying the hint on the status bar:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure ApplicationHint(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ApplicationHint(Sender: TObject);
begin
  StatusBar1.Panels[0].Text := GetLongHint(Application.Hint);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnHint := ApplicationHint;
end;

end.

How to disable copying to clipboard from a TRichEdit

Problem/Question/Abstract:

I have been trying all day to keep a descendant of TRichEdit from copying/ cutting to the clipboard with the use of the [ctrl] +[c] and [ctrl] + [x] keyboard shortcuts with no luck at all.

Answer:

Try a different approach: to copy something there has to be a selection, otherwise there is nothing to copy. So attach a handler to the controls OnSelectionChange event. This handler contains the line:

with Sender as TRichEdit do
  SelLength := 0;

How to load a main menu into a TTreeView

Problem/Question/Abstract:

How to load a main menu into a TTreeView

Answer:

procedure AddToTree(Menu: TMenuItem; Tree: TTreeView; PNode: TTreeNode);
var
  x: Integer;
  Node: TTreeNode;
begin
  Node := Tree.Items.AddChild(PNode, Menu.Caption);
  if Menu.Count > 0 then
  begin
    for x := 0 to Menu.Count - 1 do
    begin
      AddToTree(Menu.Items[x], Tree, Node);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  x: Integer;
begin
  TreeView1.Items.Clear;
  for x := 0 to MainMenu1.Items.Count - 1 do
  begin
    AddToTree(MainMenu1.Items[x], TreeView1, nil);
  end;
end;

Delphi code window doesn't receive focus on hitting breakpoints

Problem/Question/Abstract:

We have one computer at work running Delphi 4 on Win98.
When we attempt to debug our D4 exe on this machine by setting breakpoints, the D4 code window becomes the topmost window, but DOES NOT receive focus!

Answer:

Check that your WIN.INI file contains the following:

[Compatibility95]
DELPHI32=0x00000002

How to create an icon from a TBitmap

Problem/Question/Abstract:

How to create an icon from a TBitmap

Answer:

You must create two bitmaps, a mask bitmap (called the "AND" bitmap) and a image bitmap (called the XOR bitmap). You can pass the handles to the "AND" and "XOR" bitmaps to the Windows API function CreateIconIndirect() and use the returned icon handle in your application:

procedure TForm1.Button1Click(Sender: TObject);
var
  IconSizeX: Integer;
  IconSizeY: Integer;
  AndMask: TBitmap;
  XOrMask: TBitmap;
  IconInfo: TIconInfo;
  Icon: TIcon;
begin
  {Getting the icon size}
  IconSizeX := GetSystemMetrics(SM_CXICON);
  IconSizeY := GetSystemMetrics(SM_CYICON);
  {Creating the "And" mask}
  AndMask := TBitmap.Create;
  AndMask.Monochrome := true;
  AndMask.Width := IconSizeX;
  AndMask.Height := IconSizeY;
  {Drawing on the "And" mask}
  AndMask.Canvas.Brush.Color := clWhite;
  AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
  AndMask.Canvas.Brush.Color := clBlack;
  AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
  {Test drawing}
  Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);
  {Creating the "XOR" mask}
  XOrMask := TBitmap.Create;
  XOrMask.Width := IconSizeX;
  XOrMask.Height := IconSizeY;
  {Drawing onto the "XOR" mask}
  XOrMask.Canvas.Brush.Color := ClBlack;
  XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
  XOrMask.Canvas.Pen.Color := clRed;
  XOrMask.Canvas.Brush.Color := clRed;
  XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
  {Test drawing}
  Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);
  {Create an icon}
  Icon := TIcon.Create;
  IconInfo.fIcon := true;
  IconInfo.xHotspot := 0;
  IconInfo.yHotspot := 0;
  IconInfo.hbmMask := AndMask.Handle;
  IconInfo.hbmColor := XOrMask.Handle;
  Icon.Handle := CreateIconIndirect(IconInfo);
  {Destroying temporary bitmaps}
  AndMask.Free;
  XOrMask.Free;
  {Test drawing}
  Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);
  {Assigning the application's icon}
  Application.Icon := Icon;
  {Forcing a repaint}
  InvalidateRect(Application.Handle, nil, true);
  {Free the icon}
  Icon.Free;
end;

Add an image to an Excel spreadsheet

Problem/Question/Abstract:

I try to embed an image (jpg or bmp) into a spreadsheet. It will go in the top left of the spreadsheet - like a letterhead, sort of. I've seen the methods that use late binding, but the code I'm modifying use the early binding object TExcelApplication (the instance is called ExcelApplication1). The following doesn't compile:

ExcelApplication1.ActiveSheet.Pictures.Insert('c:\translogo.bmp')

I get the error "undeclared identifier: Pictures". Any suggestions?

Answer:

If WS is your worksheet:

{ ... }
WS.Shapes.AddPicture('C:\Pictures\Small.Bmp', EmptyParam, EmptyParam, 10, 160,
  EmptyParam, EmptyParam);

or

{ ... }
var
  Pics: Excel2000.Pictures; {or whichever Excel}
  Pic: Excel2000.Picture;
  Pic: Excel2000.Shape;
  Left, Top: integer;
{ ... }
Pics := (WS.Pictures(EmptyParam, 0) as Pictures);
Pic := Pics.Insert('C:\Pictures\Small.Bmp', EmptyParam);
Pic.Top := WS.Range['D4', 'D4'].Top;
Pic.Left := WS.Range['D4', 'D4'].Left;
{ ... }

EmptyParam a special variant (declared in Variants.pas in D6+). However in later versions of Delphi some conversions cause problems. This should work:

uses
  OfficeXP;

{ ... }
WS.Shapes.AddPicture('H:\Pictures\Game\Hills.bmp', msoFalse, msoTrue, 10, 160, 100,
  100);

But you may have to use a TBitmap to find out how large the picture should be.

How to create an multiple colored Stringgrid ? / How to draw in a StringGrid-Cell ?

Problem/Question/Abstract:

The standard Delphi-StringGrid can only hold one color for all cells. How to create an multiple colored Stringgrid ?

Answer:

I's easier than you assumed. You must simply override the DrawCell and manuelly draw some data on the canvas of the Stringgrid-Cell .

Feel free to copy and reuse this sweet tiny component....

I hope this article is helpful for you ....

TBWStringGrid = class(TStringGrid)
private
protected
  procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
    AState: TGridDrawState); override;
public
  { just hold some data for each cell }
  CellColor: array of array of TColor;
  CellFontColor: array of array of TColor;
  CellData: array of array of REAL;
  procedure RebuildDynColorArray; // net gut !!!!
  procedure ResizeGrid(ColCount: Integer; RowCount: Integer; ClearAllFields: Boolean =
    TRUE);
  procedure ResetGridCellData;
  procedure ResetGrid;
  procedure UnselectAll;
published
end;

function InvertColor(Color: TColor): TColor;

{ TBWStringGrid }

//>Created at 05-Jul-2002 (14:12:19 ) by benjamin wittfoth
  procedure TBWStringGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
    AState: TGridDrawState);
  begin
    inherited;
    if CellColor[ACol, ARow] = clBlack then
      EXIT;
    with Canvas do
    begin
      if (gdSelected in AState) then
      begin // wenn selektiert -> INVERTIEREN
        Font.Color := InvertColor(CellFontColor[ACol, ARow]);
        Brush.Color := InvertColor(CellColor[ACol, ARow]);
      end
      else
      begin // Ansonsten nicht !
        Brush.Color := CellColor[ACol, ARow];
        Font.Color := CellFontColor[ACol, ARow];
      end;
      Brush.Style := bsSolid;
      FillRect(ARect);
      TextRect(ARect, ARect.left + 2, ARect.top + 2, Cells[ACol, ARow]);
    end;
  end;

  //>Created at 05-Jul-2002 (14:56:33 ) by benjamin wittfoth
  procedure TBWStringGrid.RebuildDynColorArray;
  begin
    SetLength(CellColor, ColCount, RowCount);
    SetLength(CEllFontColor, ColCount, RowCount);
    SetLength(CellData, ColCount, RowCount);
  end;
  //>Created at 10-Jul-2002 (08:11:25 ) by benjamin wittfoth
  procedure TBWStringGrid.ResizeGrid(ColCount: Integer; RowCount: Integer;
    ClearAllFields: Boolean = TRUE);
  begin
    Self.RowCount := RowCount;
    Self.ColCount := ColCount;
    RebuildDynColorArray;
    if ClearAllFields then
      ResetGrid;
  end;
  //>Created at 10-Jul-2002 (08:11:29 ) by benjamin wittfoth
  procedure TBWStringGrid.ResetGridCellData;
  var
    X, Y: Integer;
  begin
    for Y := 0 to RowCount - 1 do
      for X := 0 to ColCount - 1 do
        CellData[X, Y] := 0;
  end;
  //>Created at 09-Jul-2002 (16:54:43 ) by benjamin wittfoth
  procedure TBWStringGrid.ResetGrid;
  var
    X, Y: Integer;
  begin
    for Y := 0 to RowCount - 1 do
    begin
      for X := 0 to ColCount - 1 do
      begin
        CellData[X, Y] := 0;
        CellColor[X, Y] := clWhite;
        CellFontColor[X, Y] := clBlack;
        Cells[X, Y] := '';
      end;
    end;
  end;

  //>Created at 09-Jul-2002 (11:08:35 ) by benjamin wittfoth
  procedure TBWStringGrid.UnselectAll;
  var
    ARect: TGridRect;
  begin
    ARect.Left := 0;
    ARect.Top := 0;
    ARect.Right := 0;
    ARect.Bottom := 0;
    Selection := ARect;
  end;

  function InvertColor(Color: TColor): TColor;
  begin
    case Color of
      clAqua: RESULT := clTeal;
      clBlack: RESULT := clWhite;
      clBlue: RESULT := clMaroon;
      clDkGray: RESULT := clFuchsia;
      clFuchsia: RESULT := clDkGray;
      //    clGray      : RESULT:=clPurple;
      clGreen: RESULT := clRed;
      clLime: RESULT := clSilver; //clYellow;
      clLtGray: RESULT := clLime;
      clMaroon: RESULT := clOlive; //clBlue;
      clNavy: RESULT := clNavy;
      clOlive: RESULT := clMaroon; //clNavy;
      clPurple: RESULT := clGray;
      clRed: RESULT := clYellow; //clGreen;
      //    clSilver    : RESULT:=clLtGray;
      clTeal: RESULT := clAqua;
      clWhite: RESULT := clBlack;
      clYellow: RESULT := clRed; //clLime;
    end;
  end;

How to call procedures by name using an array of records

Problem/Question/Abstract:

I have a unit that all it does is store SQL statement for me to load and right now I'm doing:

if ReportName = "Some_Report_Name" then
  LoadSomeReportNameSql;
else if ReportName = "Some_Other_Report" then
  LoadSomeOtherReportSql;

I have about 200 reports so far...would a case statment be faster? I would, of course, change the identifier for the report to a numeric identifier, rather than a string identifier. My concern is that there will begin to be a very noticable difference once I get up to the 500 or so reports.

Answer:

With that many reports, there are two better solutions than an if/ then or case statement.


Solve 1:

An array of records containing the report name and report procedure might be faster and easier to maintain. The list could be sorted on the report name, and a binary search algorithm could be used to quickly locate the correct report procedure to execute.

This method is not new, but works very well. It is not automagical, so the programmer has to do some typing. It could be improved in a myriad of ways, like array of const parameters, TVarRec results, action identifers and encapsulation in a class. The last could get hairy if you expect that class to serve objects of other classes as well, but it is possible.


unit NamedFunctions;

interface

const
  MaxFuncs = 3;
  MaxFuncName = 13;

type
  TFuncRange = 1..MaxFuncs;
  TNamedFunc = function(args: string): string;
  TFuncName = string[MaxFuncName];
  TFuncInfo = record
    Name: TFuncName;
    Func: TNamedFunc
  end; { TNamedFunc }

  TFuncList = array[TFuncRange] of TFuncInfo;
function XSqrt(args: string): string;
function XUpStr(args: string): string;
function XToggle(args: string): string;

const
  {This list must be sorted for the function to be found}
  FuncList: TFuncList = ((Name: 'xsqrt'; Func: XSqrt), (Name: 'xtoggle'; Func: XToggle), (Name: 'xupstr'; Func: XUpStr));

function ExecFunc(AName: TFuncName; args: string): string;

implementation

uses
  Dialogs, SysUtils;

function ExecFunc(AName: TFuncName; args: string): string;
{ Binary search is overkill for a small number of functions. }
var
  CompRes, i, j, m: integer;
  Found: boolean;
begin
  AName := LowerCase(AName);
  i := 1;
  j := MaxFuncs;
  m := (i + j) shr 1;
  Found := false;
  while not Found and (i <= j) do
  begin
    CompRes := AnsiCompareStr(AName, FuncList[m].Name);
    if CompRes < 0 then
      j := m - 1
    else if CompRes > 0 then
      i := m + 1
    else
      Found := true;
    if not Found then
      m := (i + j) shr 1
  end;
  if Found then
    Result := FuncList[m].Func(args)
  else
  begin
    Result := '';
    ShowMessage('Function ' + AName + ' not found in list')
  end;
end;

function XSqrt(args: string): string;
var
  value: real;
begin
  value := 0;
  try
    value := StrToFloat(args)
  except
    on EConvertError do
      ShowMessage(args + ' is not a valid real number (XStr)')
  end;
  if value >= 0 then
    Result := FloatToStr(sqrt(value))
  else
  begin
    Result := '0.0';
    ShowMessage('Negative number passed to XSqrt')
  end;
end;

function XUpStr(args: string): string;
begin
  Result := UpperCase(args)
end;

function XToggle(args: string): string;
{ Anything other than 'TRUE' or 'T' is assumed false. }
begin
  args := UpperCase(args);
  if (args = 'TRUE') or ((length(args) = 1) and (args = 'T')) then
    Result := 'FALSE'
  else
    Result := 'TRUE'
end;

end.


Solve 2:

Another way to go would be to use the GetProcAddress Win32 API function to locate the report procedure based on the report name. This way you could store the report names and report procedure names in a text file or database. (Tip: EXEs can export routines just like DLLs can. GetProcAddress only finds exported routine names). The code might look something like this (off the top of my head...):


unit MyReports;

interface

type
  TReportProcedure = procedure;

procedure LoadSomeReportNameSql;
procedure LoadSomeOtherReportSql;
procedure ExecuteReport(AReportName: string);

implementation

procedure ExecuteReport(AReportName: string);
var
  ReportProc: TReportProcedure;
  ProcPointer: TFarProc;
begin
  {Table contains two columns: "Report Name" and "Report Procedure".  Primary key is "Report Name"}
  try
    Table1.Open;
    if Table1.FindKey([AReportName]) then
    begin
      {Get the address of the exported report procedure}
      ProcPointer := GetProcAddress(HInstance, Table1.FieldByName('Report Procedure').AsString);
      if Assigned(ProcPointer) then
      begin
        ReportProcedure := TReportProcedure(ProcPointer);
        ReportProcedure;
      end;
    end;
  finally
    Table1.Close;
  end;
end;

procedure LoadSomeReportNameSql;
begin
end;

procedure LoadSomeOtherReportSql;
begin
end;

exports
  LoadSomeReportNameSql;
LoadSomeOtherReportSql;

end.

How to create a Typing Simulation in an about box

Problem/Question/Abstract:

In my about box, I'd like (when the about box window is shown) to start "typing" something (maybe in a paintbox). I mean, instead of showing some labels with the information, the program could start typing it by itself , maybe reading the information from an invisible memo on the same form and start writing it on the paintbox. For example, it could start writing letters one by one and making them sentences, also leave the spaces required and also show a graphic " | " after anything written (like in the edit controls). Could someone show some code of doing that? To better explain, I'd like to simulate the "typing" like someone is typing on the screen, leaving spaces, writing pauses, semicolons , etc.

Answer:

A way would be to put a timer on the aboutbox, and every timer click draw add an extra character. It may be best to use a TImage and draw the chars to the image. That way they will stay without needing a redraw. Here are the basic steps:

Include the text to type in a memo.

On create move the memo off screen (make invisible), set variables of say ml=memo, line=0, sp=string, position=-1, Xpos:= 0, Ypos:= 0, tmpstr:= ''

On a timer do


begin
  if (sp = -1) then
  begin
    ypos := ypos + image1.canvas.textheight('A');
    xpos := 0;
    tmpstr := memo1.lines[ml];
    Inc(ml);
    sp := 1;
  end;
  Image1.Canvas.TextOut(xpos, ypos, tmpstr[sp]);
  Inc(sp)
    xpos := xpos + image1.canvas.textwidth('A');
  if (sp > Length(TmpStr)) then
    sp := -1;
end;

How to create a flat TComboBox

Problem/Question/Abstract:

How to create a flat TComboBox

Answer:

{$IFDEF BCB}
{$OBJEXPORTALL ON}
{$ENDIF}
unit DebsFlatComboBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls;

type
  TDebsCustomFlatComboBox = class(TCustomComboBox)
  private
    FFlatButton: boolean;
    FOnChooseItem: TNotifyEvent;
    FOnCloseUp: TNotifyEvent;
    procedure SetFlatButton(const Value: boolean);
  protected
    procedure ChooseItem; virtual;
{$IFNDEF VER140}
    procedure CloseUp; virtual;
{$ENDIF}
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure DrawButton(const DC: HDC); virtual;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    property FlatButton: boolean read FFlatButton write SetFlatButton default False;
    property OnChooseItem: TNotifyEvent read FOnChooseItem write FOnChooseItem;
    property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  end;

  TDebsFlatComboBox = class(TDebsCustomFlatComboBox)
  published
    property Style; {Must be published before Items}
    property Anchors;
{$IFDEF VER140}
    property AutoComplete;
    property AutoDropDown;
{$ENDIF}
    property BiDiMode;
    property CharCase;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property DropDownCount;
    property Enabled;
    property FlatButton;
    property Font;
    property ImeMode;
    property ImeName;
    property ItemHeight;
    property ItemIndex default -1;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
    property OnChange;
    property OnChooseItem;
    property OnClick;
    property OnCloseUp;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnDropDown;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMeasureItem;
    property OnStartDock;
    property OnStartDrag;
    property Items; {Must be published after OnMeasureItem}
  end;

procedure Register;

implementation

uses
  Graphics;

procedure Register;
begin
  RegisterComponents('Debs', [TDebsFlatComboBox]);
end;

{TDebsCustomFlatComboBox}

procedure TDebsCustomFlatComboBox.ChooseItem;
begin
  if Assigned(FOnChooseItem) then
    FOnChooseItem(Self);
end;

{$IFNDEF VER140}

procedure TDebsCustomFlatComboBox.CloseUp;
begin
  if Assigned(FOnCloseUp) then
    FOnCloseUp(Self);
end;
{$ENDIF}

procedure TDebsCustomFlatComboBox.CNCommand(var Message: TWMCommand);
begin
  case Message.NotifyCode of
    CBN_SELCHANGE:
      begin
        Text := Items[ItemIndex];
        Click;
        Change;
        ChooseItem;
      end;
    CBN_CLOSEUP:
      begin
        CloseUp;
        Invalidate;
      end;
  else
    inherited;
  end;
end;

procedure TDebsCustomFlatComboBox.DrawButton(const DC: HDC);
var
  BtnState: integer;
  BtnRect: TRect;
begin
  BtnRect := ClientRect;
  BtnRect.Left := BtnRect.Right - GetSystemMetrics(SM_CXVSCROLL) - 2;
  BtnState := DFCS_SCROLLDOWN;
  if DroppedDown then
    InflateRect(BtnRect, -1, -1) {Draw line inside button for recessed look}
  else if FFlatButton then
    BtnState := BtnState or DFCS_FLAT
  else
    BtnRect.Top := BtnRect.Top + 1; {Allow room for 3d highlight}
  if not Enabled then
    BtnState := BtnState or DFCS_INACTIVE;
  if DroppedDown then
    BtnState := BtnState or DFCS_PUSHED;
  DrawFrameControl(DC, BtnRect, DFC_SCROLL, BtnState);
end;

procedure TDebsCustomFlatComboBox.SetFlatButton(const Value: boolean);
begin
  FFlatButton := Value;
  Invalidate;
end;

procedure TDebsCustomFlatComboBox.WMPaint(var Message: TWMPaint);
var
  DC: HDC;
  DrawRect: TRect;
  PS: TPaintStruct;
begin
  if not Ctl3d then
  begin
    DC := Message.DC;
    if (DC = 0) then
      DC := BeginPaint(Handle, PS);
    try
      DrawRect := ClientRect;
      Brush.Color := clWindowFrame;
      FrameRect(DC, DrawRect, Brush.Handle);
      InflateRect(DrawRect, -1, -1);
      Brush.Color := Color;
      FillRect(DC, DrawRect, Brush.Handle);
      {Draw the borders and the button}
      if Style <> csSimple then
      begin
        DrawButton(DC);
        DrawRect.Right := DrawRect.Right - GetSystemMetrics(SM_CXVSCROLL) - 2;
      end;
      {Clip the region  to stop Windows painting over our work}
      InflateRect(DrawRect, -1, -1);
      IntersectClipRect(DC, DrawRect.Left, DrawRect.Top, DrawRect.Right, DrawRect.Bottom);
      {Now get Windows to fill in the combo text}
      PaintWindow(DC);
    finally
      if Message.DC = 0 then
        EndPaint(Handle, PS);
    end;
  end
  else
    inherited;
end;

end.

Disable the close button of a TForm

Problem/Question/Abstract:

How to disable the close button of a TForm

Answer:

Solve 1:

procedure EnableCloseButton(const bEnable: Boolean);
const
  MenuFlags: array[Boolean] of Integer = (MF_DISABLED, MF_ENABLED);
var
  hSysMenu: HMENU;
begin
  hSysMenu := GetSystemMenu(Handle, False);
  if hSysMenu > 0 then
    EnableMenuItem(hSysMenu, SC_CLOSE, MF_BYCOMMAND or MenuFlags[bEnable]);
end;


Solve 2:

The usual approach is to disable or enable the corresponding item in the forms system menu. However, that does not work for all of them. You can always trap the WM_SYSCOMMAND message caused by clicking on the items and not pass it on, but this way the border icons do not appear disabled.

{ ... }
EnableMenuItem(GetSystemMenu(handle, False), SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);        

That will disable the close box, for example.


Solve 3:

Remember that certain combinations will cause different results (ie. removing the system menu will also disable minimize/ maximize etc.)

procedure TForm1.Button1Click(Sender: TObject);
var
  Style: Integer;
begin
  Style := GetWindowLong(Handle, GWL_STYLE);
  {disable minimize}
  Style := Style - WS_MINIMIZEBOX;
  {disable maximize}
  Style := Style - WS_MAXIMIZEBOX;
  {remove system menu}
  Style := Style - WS_SYSMENU;
  {set new style}
  SetWindowLong(Handle, GWL_STYLE, Style);
  {repaint the title bar}
  RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE);
end;

Send files to the recycle bin

Problem/Question/Abstract:

How to send files to the recycle bin

Answer:

Solve 1:


unit Recycle;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs, ShellAPI;

function RecycleFile(FileToRecycle: TFilename): boolean;
function RecycleFileEx(FileToRecycle: TFilename; Confirm: boolean): boolean;

implementation

function RecycleFile(FileToRecycle: TFilename): boolean;
begin
  Result := RecycleFileEx(FileToRecycle, True);
end;

function RecycleFileEx(FileToRecycle: TFilename; Confirm: boolean): boolean;
var
  Struct: TSHFileOpStruct;
  tmp: string;
  Resultval: integer;
begin
  tmp := FileToRecycle + #0#0;
  Struct.wnd := 0;
  Struct.wFunc := FO_DELETE;
  Struct.pFrom := PChar(tmp);
  Struct.pTo := nil;
  Struct.fFlags := FOF_ALLOWUNDO;
  if not Confirm then
    Struct.fFlags := Struct.fFlags or FOF_NOCONFIRMATION;
  Struct.fAnyOperationsAborted := false;
  Struct.hNameMappings := nil;
  try
    Resultval := ShFileOperation(Struct);
  except
    on e: Exception do
    begin
      e.Message := 'Tried to recycle file:' + FileToRecycle + #13#10 + e.Message;
      raise;
    end;
  end;
  Result := (Resultval = 0);
end;

end.


Solve 2:

uses ShellApi;

function DeleteFilesToRecycleBin(const APath: string): Boolean;
var
  AStruct: TShFileOpStruct;
begin
  if Length(APath) = 0 then
    Exit;
  AStruct.Wnd := 0;
  AStruct.wFunc := FO_DELETE;
  AStruct.pFrom := PChar(APath);
  AStruct.fFlags := FOF_ALLOWUNDO;
  Result := ShFileOperation(AStruct) <> 0;
end;


Solve 3:

function RecycleFile(FileToRecycle: string): boolean;
var
  Struct: TSHFileOpStruct;
  pFromc: PChar;
  Resultval: integer;
begin
  if not FileExists(FileToRecycle) then
  begin
    RecycleFile := False;
    exit;
  end
  else
  begin
    pfromc := PChar(ExpandFileName(FileToRecycle) + #0#0);
    Struct.wnd := 0;
    Struct.wFunc := FO_DELETE;
    Struct.pFrom := pFromC;
    Struct.pTo := nil;
    Struct.fFlags := FOF_ALLOWUNDO;
    Struct.fAnyOperationsAborted := false;
    Struct.hNameMappings := nil;
    Resultval := ShFileOperation(Struct);
    RecycleFile := (Resultval = 0);
  end;
end;

Find the TTabSheet in a pagecontrol, an active control is sitting on

Problem/Question/Abstract:

How to find the TTabSheet in a pagecontrol, an active control is sitting on

Answer:

The forms ActiveControl property points to the active control on the form (if any, it may be Nil under certain circumstances). If you want to find the tabsheet in a pagecontrol, this controls is sitting on, you walk up its parent chain:

var
  ctrl: TWinControl;
begin
  if ActiveControl <> nil then
  begin
    ctrl := ActiveControl.Parent;
    while (ctrl <> nil) and not (ctrl is TTabsheet) do
      ctrl := ctrl.parent;
    if ctrl <> nil then
      {... found the tabsheet, can cast it as TTabsheet( ctrl ) to access
                        its properties}

Testing if two objects are "related" or "identical" (RTTI)

Problem/Question/Abstract:

Testing if two objects are "related" or "identical" (RTTI)

Answer:

Do you need to know whether object a is of a derived class from the class that another object b is of? Or if they may even be of the same class?

The following little code snippet tells it..


program dummy;

var
  a, b: TObject;

begin
  // some code to assign the pointers
  // ...

  // now evaluate the RTTI of two instantiated objects
  if a is b then
    ShowMessage('a is derived from b or same class');

  if a.classtype = b.classtype then
    ShowMessage('a and b are of the same class');

  // alternative to ClassType comparison (slower!)
  if a.ClassName = b.ClassName then
    ShowMessage('a and b are of the same class')
end.

How to flip, rotate and mirror bitmaps

Problem/Question/Abstract:

How to flip, rotate and mirror bitmaps

Answer:

You'll have to manually set the bitmap's PixelFormat to pf8bit, pf16bit, pf24bit, or pf32bit before calling these routines. At the end of this page are three wrappers that will call the appropriate routine based on pixel format.

{ ... }
type
  TPixel8 = Byte;
  TPixel16 = Word;
  TPixel24 = packed record
    Blue: Byte;
    Green: Byte;
    Red: Byte;
  end;

  TPixel32 = LongWord;

function GetBitmapPixelSize(const Bitmap: TBitmap): Integer;
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      Result := 1;
    pf16Bit:
      Result := 2;
    pf24Bit:
      Result := 3;
    pf32Bit:
      Result := 4;
  else
    Result := 0;
  end;
end;

function GetBitmapScanlineSize(const Bitmap: TBitmap): Integer;
var
  SL0: Pointer;
  SL1: Pointer;
begin
  if (Bitmap.Height > 1) then
  begin
    SL0 := Bitmap.Scanline[0];
    SL1 := Bitmap.Scanline[1];
    Result := LongInt(SL1) - LongInt(SL0);
  end
  else
    Result := 0;
end;

procedure FlipBitmap_8(const Bitmap: TBitmap);
type
  TPixel = TPixel8; {Dependent on Bitmap.PixelFormat}
  PPixel = ^TPixel;
var
  Buffer: TPixel;
  PPixel1: PPixel;
  PPixel2: PPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  for I := 1 to (Bitmap.Height div 2) do {Ignore middle row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Inc(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure FlipBitmap_16(const Bitmap: TBitmap);
type
  TPixel = TPixel16; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  Buffer: TPixel;
  PPixel1: PPixel;
  PPixel2: PPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  for I := 1 to (Bitmap.Height div 2) do {Ignore middle row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Inc(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure FlipBitmap_24(const Bitmap: TBitmap);
type
  TPixel = TPixel24; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  Buffer: TPixel;
  PPixel1: PPixel;
  PPixel2: PPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  for I := 1 to (Bitmap.Height div 2) do {Ignore middle row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Inc(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure FlipBitmap_32(const Bitmap: TBitmap);
type
  TPixel = TPixel32; {Dependent on PixelFormat.}
  PPixel = ^TPixel;
var
  Buffer: TPixel;
  PPixel1: PPixel;
  PPixel2: PPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  for I := 1 to (Bitmap.Height div 2) do {Ignore middle row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Inc(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure MirrorBitmap_8(const Bitmap: TBitmap);
type
  TPixel = TPixel8; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := PPixel1Start;
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to Bitmap.Height do
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore middle column}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Inc(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure MirrorBitmap_16(const Bitmap: TBitmap);
type
  TPixel = TPixel16; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := PPixel1Start;
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to Bitmap.Height do
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore middle column}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Inc(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure MirrorBitmap_24(const Bitmap: TBitmap);
type
  TPixel = TPixel24; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := PPixel1Start;
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to Bitmap.Height do
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore middle column}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Inc(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure MirrorBitmap_32(const Bitmap: TBitmap);
type
  TPixel = TPixel32; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := PPixel1Start;
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to Bitmap.Height do
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore middle column}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Inc(LongInt(PPixel2Start), RowSize);
  end;
end;

procedure RotateBitmap180_8(const Bitmap: TBitmap);
type
  TPixel = TPixel8; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to (Bitmap.Height div 2) do {Ignore center row for now}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
  if (Odd(Bitmap.Height)) then {Process center row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore center pixel}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
  end;
end;

procedure RotateBitmap180_16(const Bitmap: TBitmap);
type
  TPixel = TPixel16; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to (Bitmap.Height div 2) do {Ignore center row for now}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
  if (Odd(Bitmap.Height)) then {Process center row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore center pixel}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
  end;
end;

procedure RotateBitmap180_24(const Bitmap: TBitmap);
type
  TPixel = TPixel24; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to (Bitmap.Height div 2) do {Ignore center row for now}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
  if (Odd(Bitmap.Height)) then {Process center row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore center pixel}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
  end;
end;

procedure RotateBitmap180_32(const Bitmap: TBitmap);
type
  TPixel = TPixel32; {Dependent on PixelFormat}
  PPixel = ^TPixel;
var
  PPixel1: PPixel;
  PPixel2: PPixel;
  Buffer: TPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  RowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  RowSize := GetBitmapScanlineSize(Bitmap);
  PPixel1Start := Bitmap.Scanline[0];
  PPixel2Start := Bitmap.Scanline[Bitmap.Height - 1];
  Inc(PPixel2Start, Bitmap.Width - 1);
  for I := 1 to (Bitmap.Height div 2) do {Ignore center row for now}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to Bitmap.Width do
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
    Inc(LongInt(PPixel1Start), RowSize);
    Dec(LongInt(PPixel2Start), RowSize);
  end;
  if (Odd(Bitmap.Height)) then {Process center row}
  begin
    PPixel1 := PPixel1Start;
    PPixel2 := PPixel2Start;
    for J := 1 to (Bitmap.Width div 2) do {Ignore center pixel}
    begin
      Buffer := PPixel1^;
      PPixel1^ := PPixel2^;
      PPixel2^ := Buffer;
      Inc(PPixel1);
      Dec(PPixel2);
    end;
  end;
end;

procedure RotateBitmapCW_32(const Bitmap: TBitmap);
type
  TPixel = TPixel32; {Dependent on Bitmap.PixelFormat}
  PPixel = ^TPixel;
var
  NewBitmap: TBitmap;
  PPixel1: PPixel;
  PPixel2: PPixel;
  PPixel1Start: PPixel;
  PPixel2Start: PPixel;
  I: Integer;
  J: Integer;
  BitmapRowSize: Integer;
  NewBitmapRowSize: Integer;
begin
  Assert(GetBitmapPixelSize(Bitmap) = SizeOf(TPixel));
  Assert(Bitmap.Height > 0);
  Assert(Bitmap.Width > 0);
  NewBitmap := TBitmap.Create;
  try
    NewBitmap.PixelFormat := Bitmap.PixelFormat;
    NewBitmap.Height := Bitmap.Width;
    NewBitmap.Width := Bitmap.Height;
    BitmapRowSize := GetBitmapScanlineSize(Bitmap);
    NewBitmapRowSize := GetBitmapScanlineSize(NewBitmap);
    PPixel1Start := Bitmap.Scanline[0];
    PPixel2Start := NewBitmap.Scanline[0];
    Inc(PPixel2Start, NewBitmap.Width - 1);
    for I := 0 to (Bitmap.Height - 1) do
    begin
      PPixel1 := PPixel1Start;
      PPixel2 := PPixel2Start;
      for J := 0 to (Bitmap.Width - 1) do
      begin
        PPixel2^ := PPixel1^;
        Inc(PPixel1);
        Inc(Integer(PPixel2), NewBitmapRowSize);
      end;
      Inc(Integer(PPixel1Start), BitmapRowSize);
      Dec(PPixel2Start);
    end;
    Bitmap.Assign(NewBitmap);
  finally
    NewBitmap.Free;
  end;
end;

procedure FlipBitmap(const Bitmap: TBitmap);
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      FlipBitmap_8(Bitmap);
    pf16Bit:
      FlipBitmap_16(Bitmap);
    pf24Bit:
      FlipBitmap_24(Bitmap);
    pf32Bit:
      FlipBitmap_32(Bitmap);
  else
    Assert(False);
  end;
end;

procedure MirrorBitmap(const Bitmap: TBitmap);
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      MirrorBitmap_8(Bitmap);
    pf16Bit:
      MirrorBitmap_16(Bitmap);
    pf24Bit:
      MirrorBitmap_24(Bitmap);
    pf32Bit:
      MirrorBitmap_32(Bitmap);
  else
    Assert(False);
  end;
end;

procedure RotateBitmap180(const Bitmap: TBitmap);
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      RotateBitmap180_8(Bitmap);
    pf16Bit:
      RotateBitmap180_16(Bitmap);
    pf24Bit:
      RotateBitmap180_24(Bitmap);
    pf32Bit:
      RotateBitmap180_32(Bitmap);
  else
    Assert(False);
  end;
end;

procedure RotateBitmapCW(const Bitmap: TBitmap);
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      ;
    pf16Bit:
      ;
    pf24Bit:
      ;
    pf32Bit:
      RotateBitmapCW_32(Bitmap);
  else
    Assert(False);
  end;
end;

procedure RotateBitmapCCW(const Bitmap: TBitmap);
begin
  case Bitmap.PixelFormat of
    pf8Bit:
      ;
    pf16Bit:
      ;
    pf24Bit:
      ;
    pf32Bit:
      ;
  else
    Assert(False);
  end;
end;

How can i write a TColor to a TInifile

Problem/Question/Abstract:

How can i write a TColor to a TInifile?

Answer:

To save the color to an INI, simply call IntToStr on the color (since TColor is an Integer) and then write the value as you would any other string.
TIniFile.WriteInteger(....), no need to convert to a string.


var
  t: TIniFile;
  c: color;
begin
  t := Tinifile.create('test.ini');
  //to write it
  t.writeinteger('section', 'identifier', integer(c));
  //to read it
  c := TColor(t.readinteger('section', 'identifier', clblack));
end;

How to save object property data to a stream

Problem/Question/Abstract:

How can I save properties of a TList to a stream? I need the entire list to be saved as a whole and not as individual objects.

Answer:

Solve 1:

A TList doesn't have any intrinsic streaming capability built into it, but it is very easy to stream anything that you want with a little elbow grease. Think about it: a stream is data. Classes have properties, whose values are data. It isn't too hard to write property data to a stream. Here's a simple example to get you going. This is but just one of many possible approaches to saving object property data to a stream:

unit uStreamableExample;

interface

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

type
  TStreamableObject = class(TPersistent)
  protected
    function ReadString(Stream: TStream): string;
    function ReadLongInt(Stream: TStream): LongInt;
    function ReadDateTime(Stream: TStream): TDateTime;
    function ReadCurrency(Stream: TStream): Currency;
    function ReadClassName(Stream: TStream): ShortString;
    procedure WriteString(Stream: TStream; const Value: string);
    procedure WriteLongInt(Stream: TStream; const Value: LongInt);
    procedure WriteDateTime(Stream: TStream; const Value: TDateTime);
    procedure WriteCurrency(Stream: TStream; const Value: Currency);
    procedure WriteClassName(Stream: TStream; const Value: ShortString);
  public
    constructor CreateFromStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
  end;

  TStreamableObjectClass = class of TStreamableObject;

  TPerson = class(TStreamableObject)
  private
    FName: string;
    FBirthDate: TDateTime;
  public
    constructor Create(const AName: string; ABirthDate: TDateTime);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: string read FName write FName;
    property BirthDate: TDateTime read FBirthDate write FBirthDate;
  end;

  TCompany = class(TStreamableObject)
  private
    FName: string;
    FRevenues: Currency;
    FEmployeeCount: LongInt;
  public
    constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount:
      LongInt);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: string read FName write FName;
    property Revenues: Currency read FRevenues write FRevenues;
    property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount;
  end;

  TStreamableList = class(TStreamableObject)
  private
    FItems: TObjectList;
    function Get_Count: LongInt;
    function Get_Objects(Index: LongInt): TStreamableObject;
  public
    constructor Create;
    destructor Destroy; override;
    function FindClass(const AClassName: string): TStreamableObjectClass;
    procedure Add(Item: TStreamableObject);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Objects[Index: LongInt]: TStreamableObject read Get_Objects; default;
    property Count: LongInt read Get_Count;
  end;

  TForm1 = class(TForm)
    SaveButton: TButton;
    LoadButton: TButton;
    procedure SaveButtonClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    Path: string;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

resourcestring
  DEFAULT_FILENAME = 'test.dat';

procedure TForm1.SaveButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
begin
  List := TStreamableList.Create;
  try
    List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68')));
    List.Add(TCompany.Create('Fenestra', 1000000, 7));
    Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate);
    try
      List.SaveToStream(Stream);
    finally
      Stream.Free;
    end;
  finally
    List.Free;
  end;
end;

{ TPerson }

constructor TPerson.Create(const AName: string; ABirthDate: TDateTime);
begin
  inherited Create;
  FName := AName;
  FBirthDate := ABirthDate;
end;

procedure TPerson.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FBirthDate := ReadDateTime(Stream);
end;

procedure TPerson.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteDateTime(Stream, FBirthDate);
end;

{ TStreamableList }

procedure TStreamableList.Add(Item: TStreamableObject);
begin
  FItems.Add(Item);
end;

procedure TStreamableList.Clear;
begin
  FItems.Clear;
end;

constructor TStreamableList.Create;
begin
  FItems := TObjectList.Create;
end;

procedure TStreamableList.Delete(Index: LongInt);
begin
  FItems.Delete(Index);
end;

destructor TStreamableList.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TStreamableList.FindClass(const AClassName: string): TStreamableObjectClass;
begin
  Result := TStreamableObjectClass(Classes.FindClass(AClassName));
end;

function TStreamableList.Get_Count: LongInt;
begin
  Result := FItems.Count;
end;

function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject;
begin
  Result := FItems[Index] as TStreamableObject;
end;

procedure TStreamableList.LoadFromStream(Stream: TStream);
var
  StreamCount: LongInt;
  I: Integer;
  S: string;
  ClassRef: TStreamableObjectClass;
begin
  StreamCount := ReadLongInt(Stream);
  for I := 0 to StreamCount - 1 do
  begin
    S := ReadClassName(Stream);
    ClassRef := FindClass(S);
    Add(ClassRef.CreateFromStream(Stream));
  end;
end;

procedure TStreamableList.SaveToStream(Stream: TStream);
var
  I: Integer;
begin
  WriteLongInt(Stream, Count);
  for I := 0 to Count - 1 do
  begin
    WriteClassName(Stream, Objects[I].ClassName);
    Objects[I].SaveToStream(Stream);
  end;
end;

{ TStreamableObject }

constructor TStreamableObject.CreateFromStream(Stream: TStream);
begin
  inherited Create;
  LoadFromStream(Stream);
end;

function TStreamableObject.ReadClassName(Stream: TStream): ShortString;
begin
  Result := ReadString(Stream);
end;

function TStreamableObject.ReadCurrency(Stream: TStream): Currency;
begin
  Stream.Read(Result, SizeOf(Currency));
end;

function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime;
begin
  Stream.Read(Result, SizeOf(TDateTime));
end;

function TStreamableObject.ReadLongInt(Stream: TStream): LongInt;
begin
  Stream.Read(Result, SizeOf(LongInt));
end;

function TStreamableObject.ReadString(Stream: TStream): string;
var
  L: LongInt;
begin
  L := ReadLongInt(Stream);
  SetLength(Result, L);
  Stream.Read(Result[1], L);
end;

procedure TStreamableObject.WriteClassName(Stream: TStream; const Value: ShortString);
begin
  WriteString(Stream, Value);
end;

procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value: Currency);
begin
  Stream.Write(Value, SizeOf(Currency));
end;

procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value: TDateTime);
begin
  Stream.Write(Value, SizeOf(TDateTime));
end;

procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt);
begin
  Stream.Write(Value, SizeOf(LongInt));
end;

procedure TStreamableObject.WriteString(Stream: TStream; const Value: string);
var
  L: LongInt;
begin
  L := Length(Value);
  WriteLongInt(Stream, L);
  Stream.Write(Value[1], L);
end;

{ TCompany }

constructor TCompany.Create(const AName: string; ARevenues: Currency;
  AEmployeeCount: Integer);
begin
  FName := AName;
  FRevenues := ARevenues;
  FEmployeeCount := AEmployeeCount;
end;

procedure TCompany.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FRevenues := ReadCurrency(Stream);
  FEmployeeCount := ReadLongInt(Stream);
end;

procedure TCompany.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteCurrency(Stream, FRevenues);
  WriteLongInt(Stream, FEmployeeCount);
end;

procedure TForm1.LoadButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
  Instance: TStreamableObject;
  I: Integer;
begin
  Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead);
  try
    List := TStreamableList.Create;
    try
      List.LoadFromStream(Stream);
      for I := 0 to List.Count - 1 do
      begin
        Instance := List[I];
        if Instance is TPerson then
          ShowMessage(TPerson(Instance).Name);
        if Instance is TCompany then
          ShowMessage(TCompany(Instance).Name);
      end;
    finally
      List.Free;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Path := ExtractFilePath(Application.ExeName);
end;

initialization
  RegisterClasses([TPerson, TCompany]);

end.


Solve 2:

The solution above will work, but it forces you to implement streaming support for each of the TStreamableObject objects. Delphi has already implemented this mechanism in for the TPersistent class and the TComponent class, and you can use this mechanism. The class I include here does the job. It holds classes that inherit from TUmbCollectionItem (which in turn inherits from Delphi TCollectionItem), and handles all the streaming of the items. As the items are written with the Delphi mechanism, all published data is streamed.

Notes: This class does not support working within the delphi IDE like TCollection. All objects inheriting from TUmbCollectionItem must be registered using the Classes.RegisterClass function. All objects inheriting from TUmbCollectionItem must implement the assign function. By default, the TUmbCollection owns its items (frees them when the collection is freed), but this functionality can be changed.

unit UmbCollection;

interface

uses
  Windows, Messages, SysUtils, Classes, contnrs;

type
  TUmbCollectionItemClass = class of TUmbCollectionItem;
  TUmbCollectionItem = class(TCollectionItem)
  private
    FPosition: Integer;
  public
    {when overriding this method, you must call the inherited assign.}
    procedure Assign(Source: TPersistent); override;
  published
    {the position property is used by the streaming mechanism to place the object in the
    right position when reading the items. do not use this property.}
    property Position: Integer read FPosition write FPosition;
  end;

  TUmbCollection = class(TObjectList)
  private
    procedure SetItems(Index: Integer; Value: TUmbCollectionItem);
    function GetItems(Index: Integer): TUmbCollectionItem;
  public
    function Add(AObject: TUmbCollectionItem): Integer;
    function Remove(AObject: TUmbCollectionItem): Integer;
    function IndexOf(AObject: TUmbCollectionItem): Integer;
    function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean = True;
      AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TUmbCollectionItem);

    procedure WriteToStream(AStream: TStream); virtual;
    procedure ReadFromStream(AStream: TStream); virtual;

    property Items[Index: Integer]: TUmbCollectionItem read GetItems write SetItems;
      default;
  published
    property OwnsObjects;
  end;

implementation

{ TUmbCollection }

function ItemsCompare(Item1, Item2: Pointer): Integer;
begin
  Result := TUmbCollectionItem(Item1).Position - TUmbCollectionItem(Item2).Position;
end;

function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Add(AObject);
end;

function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass;
  AExact: Boolean; AStartAt: Integer): Integer;
begin
  Result := inherited FindInstanceOf(AClass, AExact, AStartAt);
end;

function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem;
begin
  Result := inherited Items[Index] as TUmbCollectionItem;
end;

function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem);
begin
  inherited Insert(Index, AObject);
end;

procedure TUmbCollection.ReadFromStream(AStream: TStream);
var
  Reader: TReader;
  Collection: TCollection;
  ItemClassName: string;
  ItemClass: TUmbCollectionItemClass;
  Item: TUmbCollectionItem;
  i: Integer;
begin
  Clear;
  Reader := TReader.Create(AStream, 1024);
  try
    Reader.ReadListBegin;
    while not Reader.EndOfList do
    begin
      ItemClassName := Reader.ReadString;
      ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName));
      Collection := TCollection.Create(ItemClass);
      try
        Reader.ReadValue;
        Reader.ReadCollection(Collection);
        for i := 0 to Collection.Count - 1 do
        begin
          item := ItemClass.Create(nil);
          item.Assign(Collection.Items[i]);
          Add(Item);
        end;
      finally
        Collection.Free;
      end;
    end;
    Sort(ItemsCompare);
    Reader.ReadListEnd;
  finally
    Reader.Free;
  end;
end;

function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Remove(AObject);
end;

procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem);
begin
  inherited Items[Index] := Value;
end;

procedure TUmbCollection.WriteToStream(AStream: TStream);
var
  Writer: TWriter;
  CollectionList: TObjectList;
  Collection: TCollection;
  ItemClass: TUmbCollectionItemClass;
  ObjectWritten: array of Boolean;
  i, j: Integer;
begin
  Writer := TWriter.Create(AStream, 1024);
  CollectionList := TObjectList.Create(True);
  try
    Writer.WriteListBegin;
    {init the flag array and the position property of the TCollectionItem objects.}
    SetLength(ObjectWritten, Count);
    for i := 0 to Count - 1 do
    begin
      ObjectWritten[i] := False;
      Items[i].Position := i;
    end;
    {write the TCollectionItem objects. we write first the name of the objects class,
    then write all the object of the same class.}
    for i := 0 to Count - 1 do
    begin
      if ObjectWritten[i] then
        Continue;
      ItemClass := TUmbCollectionItemClass(Items[i].ClassType);
      Collection := TCollection.Create(ItemClass);
      CollectionList.Add(Collection);
      {write the items class name}
      Writer.WriteString(Items[i].ClassName);
      {insert the items to the collection}
      for j := i to Count - 1 do
        if ItemClass = Items[j].ClassType then
        begin
          ObjectWritten[j] := True;
          (Collection.Add as ItemClass).Assign(Items[j]);
        end;
      {write the collection}
      Writer.WriteCollection(Collection);
    end;
  finally
    CollectionList.Free;
    Writer.WriteListEnd;
    Writer.Free;
  end;
end;

{ TUmbCollectionItem }

procedure TUmbCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TUmbCollectionItem then
    Position := (Source as TUmbCollectionItem).Position
  else
    inherited;
end;

end.

Compilerswitch {$HINTS} (Delphi 2/ 3 only)

Problem/Question/Abstract:

Compilerswitch {$HINTS} (Delphi 2/ 3 only)

Answer:

Delphi 2/3 can tell you about minor errors in your code such as declaring a variable and not using it or writing to a variable and not using the stored value.

By default, the hints and warnings are switched off. You can switch them on

either on a global level (for all units in a project): To view these hints for an entire project, open the Project Options dialog box, go on the Compiler page and select the Show Hints checkbox.

even within a small section of a given unit. To view only the hints that apply to a section of code, use the {$HINTS ON} and {$HINTS OFF} compiler directives, as shown below:


{$HINTS ON}
procedure aProc;
var
  X: Integer;
begin
  ShowMessage('X is not used');
end;
{$HINTS OFF}

How to adjust a memo to the height required to show all text without scrollbars

Problem/Question/Abstract:

How would I find out how many viewed lines are in a memo? For example, if one line is wrapped once, it would count as two. I need to stretch it so that all lines are visible.

Answer:

Solve 1:

Adjusting a memo to the height required to show all text without scrollbars:

procedure TForm1.Button2Click(Sender: TObject);
var
  rect1, rect2: TRect;
  S: string;
begin
  s := Memo1.Text;
  memo1.Perform(EM_GETRECT, 0, longint(@rect1));
  rect2 := rect1;
  canvas.font := memo1.font;
  DrawTextEx(canvas.handle, Pchar(S), Length(S), rect2, DT_CALCRECT or
    DT_EDITCONTROL or DT_WORDBREAK or DT_NOPREFIX, nil);
  memo1.Height := memo1.height + rect2.bottom - rect1.bottom;
end;


Solve 2:

I use the following:

with TControlCanvas.Create do
try
  Control := MmoView;
  Font.Assign(MmoView.Font);
  FFontHeight := TextHeight('Q');
  FFontWidth :=
    TextWidth('abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ') div 52;
finally
  Free;
end;

FMaxBuf := (MmoView.ClientHeight div FFontHeight) * (MmoView.ClientWidth div
  FFontWidth);
FMaxLines := (MmoView.ClientHeight div FFontHeight) - 1;

I/O Error during OpenFile OF_READWRITE

Problem/Question/Abstract:

Why am I getting the error "I/O Error during "OpenFile OF_READWRITE" operation for file XXX" when attempting to open/connect to a database?

Answer:

This error is caused by an invalid file name. Either the file or the directory do not exist, or the user has insufficient rights to the database.

Bug in StringReplace (Handling Null characters) (fixed)

Problem/Question/Abstract:

I've noticed a problem when you try to use StringReplace on a string which contains NULL (#0) characters (not null terminated).

Answer:

There is an undocumented bug in the StringReplace function.

It appears that it does not handle strings will NULL (#0) characters in them.

Here is a better routine which handles NULL correctly.


function customStringReplace(OriginalString, Pattern, Replace: string): string;

{-----------------------------------------------------------------------------

��Procedure: customStringReplace
��Date:������07-Feb-2002
��Arguments: OriginalString, Pattern, Replace: string
��Result:����string
��Description:
����Replaces Pattern with Replace in string OriginalString.
����Taking into account NULL (#0) characters.
����I cheated. This is ripped almost directly from Borland's
����StringReplace Function. The bug creeps in with the ANSIPos
����function. (Which does not detect #0 characters)

-----------------------------------------------------------------------------}

var
  ��SearchStr, Patt, NewStr: string;
  ��Offset: Integer;
begin
  ��Result := '';
  ��SearchStr := OriginalString;
  ��Patt := Pattern;
  ��NewStr := OriginalString;
  ��while SearchStr <> '' do
  ��begin
  ����Offset := Pos(Patt, SearchStr); // Was AnsiPos
  ����if Offset = 0 then
  ����begin
  ������Result := Result + NewStr;
  ������Break;
  ����end;
  ����Result := Result + Copy(NewStr, 1, Offset - 1) + Replace;
  ����NewStr := Copy(NewStr, Offset + Length(Pattern), MaxInt);
  ����SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  ��end;
end;

Catching Browsers URLs with DDE

Problem/Question/Abstract:

I try to catch all URLs that all instances of the web browser visit. I try to achieve this with DDE, but sometimes miss URLs.

Answer:

I did the same job not long ago. The code works alright with Netscape but with IE you will run into a problem.

If you start IE and then open additional windows with the 'New Window' menu item, then you are running only ONE instance and you will get successfully all URLs.

BUT:

If you start a second instance of IE by clicking on the icon in your start menu a second.. then only one of your two instances will report DDE messages to your Delphi program. Usually the first started one seems to reply.

There is no clean solution around it.

I ended up enumerating top level windows and manually checking each top level window whether it was an IE instance. Then I would move through the child window chain with FindWindow(), GetWindowClass() and so on.. and retrieve the URL that way. The same code actually worked for IE 4, IE 5.0 and IE 5.5. I did not test with IE 6.

The code needed a modification for Netscape, naturally.