How to use the Wininit.ini to delete files on startup

Problem/Question/Abstract:

Can anyone tell me how to delete several files using wininit.ini please?I've seen an example somewhere that included the following :

[Rename]
NULL=C:\temp\readme.txt

Using the regular inifile calls, I cant use the above method for deleting several files because each WriteString would overwrite previous "NULL=" entries. I'm unable to find any info about using wininit.ini anywhere, there might be a [delete] section for all I know.

Answer:

This will do the job:

procedure DeleteAtReboot(FileList: TStringList);
var
  SList: TStringList;
  szContents: string;
  i, SectionFoundIndex: Integer;
  WinDir: array[0..MAX_PATH] of char;
  WinFile: string;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    {Use MoveFileEx}
    for i := 0 to FileList.count - 1 do
      MoveFileEx(PChar(FileList[i]), nil, MOVEFILE_DELAY_UNTIL_REBOOT);
  end
  else
  begin
    GetWindowsDirectory(WinDir, MAX_PATH);
    WinFile := IncludeTrailingBackslash(WinDir) + 'Wininit.ini';
    SList := TStringList.Create;
    try
      SectionFoundIndex := -1;
      {Load it if it exists}
      if FileExists(WinFile) then
        SList.LoadFromFile(WinFile);
      for i := 0 to SList.Count - 1 do
      begin
        szContents := uppercase(SList[i]);
        if UpperCase(SList[i]) = '[RENAME]' then
        begin
          SectionFoundIndex := i;
          break;
        end;
      end;
      {Rename Section doesn't exist...}
      if SectionFoundIndex = -1 then
        SectionFoundIndex := SList.Add('[Rename]');
      {Now Add our Files}
      for i := 0 to FileList.count - 1 do
        SList.Insert(SectionFoundIndex + 1, 'NUL=' + FileList[i]);
      SList.SaveToFile(WinFile);
    finally
      SList.Free;
    end;
  end;
end;

How to move the active record in a table to a certain position on a TDBGrid

Problem/Question/Abstract:

Does anyone know of a way to move the active record in a table to a certain position on a TDBGrid (i.e. the centre of a grid, top or bottom, or row number)

Answer:

This is a method that I use in a subclassed DBGrid. You can save the original row with:

OldRow := Row - TopRow;

and move with:

MoveToRow(OldRow);


procedure TMyDBGrid.MoveToRow(NewRow: Integer);
{Scrolls the visible records so that the current record is shown on the NewRow position (if possible)}
var
  Mark: TBookmarkStr;
begin
  Mark := DataLink.DataSet.Bookmark;
  {Set the current row to NewRow. This also moves the record pointer}
  DataLink.ActiveRecord := NewRow;
  {Goto the original record}
  DbiSetToBookmark(TDBDataSet(DataLink.DataSet).Handle, Pointer(Mark));
  {Force a reread of the record buffer with the current settings}
  DataLink.DataSet.Resync([rmExact]);
end;


Row, TopRow and DataLink are protected properties of DBGrid, so they can only be used
in (or through) a subclass.

How to autoscale a TBitmap while keeping the aspect ratio

Problem/Question/Abstract:

How to autoscale a TBitmap while keeping the aspect ratio

Answer:

Explanation on explicit demand!

procedure TForm1.Image1Paint(Sender: TObject);
var
  Bitmap: TBitmap;
  Breite, Hoehe: Real;
  links, rechts, oben, unten: integer;
  Feld: TRect;
begin
  Image1.Canvas.Pen.Color := Form1.Color;
  Image1.Canvas.Brush.Color := Form1.Color;
  Feld.Left := 0;
  Feld.Right := Image1.Width;
  Feld.Top := 0;
  Feld.Bottom := Image1.Height;
  Image1.Canvas.Rectangle(Feld);
  Application.ProcessMessages;
  Bitmap := TBitmap.Create;
  Bitmap.PixelFormat := pf24bit;
  Bitmap.LoadFromFile('C:\Bild.bmp');
  Breite := Bitmap.Width / Image1.Width;
  Hoehe := Bitmap.Height / Image1.Height;
  if Breite >= Hoehe then
  begin
    links := 0;
    rechts := Image1.Width;
    oben := (Image1.Height - Trunc(Bitmap.Height / Breite)) div 2;
    unten := oben + Trunc(Bitmap.Height / Breite);
  end
  else
  begin
    oben := 0;
    unten := Image1.Height;
    links := (Image1.Width - Trunc(Bitmap.Width / Hoehe)) div 2;
    rechts := links + Trunc(Bitmap.Width / Hoehe)
  end;
  Feld.Left := links;
  Feld.Right := rechts;
  Feld.Top := oben;
  Feld.Bottom := unten;
  Image1.Canvas.StretchDraw(Feld, Bitmap);
  Bitmap.Free;
end;

Fade out a bitmap

Problem/Question/Abstract:

Fade out a bitmap

Answer:

Put a TImage and load a bitmap of 24 bits  or 32 bits, put a TButton on the form and this code in its OnClick event

procedure TForm1.Button1Click(Sender: TObject);
  procedure FadeOut(const BMP: TImage; Pause: integer);
  var
    BytesPorScan: integer;
    w, h: integer;
    p: pByteArray;
    counter: integer;
  begin
    { This only works with 24 or 32 bits bitmaps }

    if not (BMP.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
      raise exception.create('Error, bitmap format not supported.');

    try
      BytesPorScan := Abs(Integer(BMP.Picture.Bitmap.ScanLine[1]) -
        Integer(BMP.Picture.Bitmap.ScanLine[0]));
    except
      raise exception.create('Error');
    end;

    { Decrease the RGB components of each single pixel }
    for counter := 1 to 256 do
    begin
      for h := 0 to BMP.Picture.Bitmap.Height - 1 do
      begin
        P := BMP.Picture.Bitmap.ScanLine[h];
        for w := 0 to BytesPorScan - 1 do
          if P^[w] > 0 then
            P^[w] := P^[w] - 1;
      end;
      Sleep(Pause);
      BMP.Refresh;
    end;
  end; {procedure FadeOut}

begin
  FadeOut(Image1, 5);
end;

Add an item to the menu in Word

Problem/Question/Abstract:

How to add an item to the menu in Word

Answer:

{ ... }
var
  CBar: CommandBar;
  MenuItem: OleVariant;
  { ... }

{ Add an item to the File menu }
CBar := Word.CommandBars['File'];
MenuItem := CBar.Controls.Add(msoControlButton, EmptyParam, EmptyParam,
  EmptyParam, True) as CommandBarButton;
MenuItem.Caption := 'NewMenuItem';
MenuItem.DescriptionText := 'Does nothing';
{Note that a VB macro with the right name must exist before you assign it to the item!}
MenuItem.OnAction := 'VBMacroName';
{ ... }

Move a form without a caption bar

Problem/Question/Abstract:

I have a panel that acts as a custom title bar, i.e. the window should be dragged by clicking inside this panel. In this case WM_NCHITTEST is not posted to TForm when the mouse pointer is over TPanel.

Answer:

Solve 1:

Basically you intercept the mouse-down and convert it into the equivalent of choosing "Move" from the System menu. You can hook the main form and any container-objects such as panels to the same handler.

procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then
    Exit;
  if Shift <> [ssLeft] then
    Exit;
  ReleaseCapture;
  Perform(WM_SYSCOMMAND, SC_MOVE + 2, Integer(PointToSmallPoint(Point(X, Y))));
end;


Solve 2:

var
  OldX, OldY: Integer;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  OldX := X;
  OldY := Y;
end;

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
    Form1.SetBounds(Left + (X - OldX), Top + (Y - OldY), Width, Height);
end;

Locate on a non-indexed field in a TTable

Problem/Question/Abstract:

How to locate on a non-indexed field in a TTable

Answer:

The following function can be added to your to your unit and called as follows:

Locate(Table1, Table1LName, 'Beman');

Table1 is your table component, Table1LName is TField you've add with the fields editor (double click on the table component) and 'Beman' is the name you want to find.

Locate will find SValue in a non-indexed table

function Locate(const oTable: TTable; const oField: TField;
  const sValue: string): Boolean;
var

  bmPos: TBookMark;
  bFound: Boolean;
begin
  Locate := False;
  bFound := False;
  if not oTable.Active then
    Exit;
  if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then
    Exit;
  bmPos := oTable.GetBookMark;
  with oTable do
  begin
    DisableControls;
    First;
    while not EOF do
      if oField.AsString = sValue then
      begin
        Locate := True;
        bFound := True;
        Break;
      end
      else
        Next;
  end;
  if (not bFound) then
    oTable.GotoBookMark(bmPos);
  oTable.FreeBookMark(bmPos);
  oTable.EnableControls;
end;

Combobox with colors

Problem/Question/Abstract:

Combobox with colors

Answer:

It is quite easy to create a combobox that shows a list of colors. You need to set the property "Style" to "csOwnerDrawFixed". This causes a call of "OnDrawItem" for each item in your combobox. The DrawItem routine draws a color bar..


// in FormCreate:
with ComboBox1.Items do
begin
  Add(IntToStr(clRed));
  Add(IntToStr(clFuchsia));
  Add(IntToStr(clBlue));
  Add(IntToStr(clGreen));
  Add(IntToStr(clYellow));
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  with Control as TComboBox, Canvas do
  begin
    // fill the rectangle first with white
    Brush.Color := clWhite;
    FillRect(Rect);
    // then reduce it and fill it with the color
    InflateRect(Rect, -2, -2);
    Brush.Color := StrToInt(Items[Index]);
    FillRect(Rect);
  end;
end;

Compact an Access database

Problem/Question/Abstract:

Using D6 Pro, Access XP and Jet 4.0 Sp6 - how can I compact Access files?

Answer:

This does it:

procedure TMainForm.ActionCompactAccessDBExecute(Sender: TObject);
var
  JetEngine: Variant;
  TempName: string;
  aAccess: string;
  stAccessDB: string;
  SaveCursor: TCursor;
begin
  stAccessDB := 'Provider = Microsoft.Jet.OLEDB.4.0;' +
    'Data Source = %s;Jet OLEDB: Engine type = ';
  stAccessDB := stAccessDB + '5'; {5 for Access 2000 and 4 for Access 97}
  OpenDialog1.InitialDir := oSoftConfig.ApplicationPath + 'Data\';
  OpenDialog1.Filter := 'MS Access (r) (*.mdb)|*.mdb';
  if OpenDialog1.execute and (uppercase(ExtractFileExt
    (OpenDialog1.FileName)) = '.MDB') then
  begin
    if MessageDlg('This process can take several minutes. Please wait till the end ' +
      #13 + #10 + 'of it. Do you want to proceed? Press No to exit.', mtInformation,
      [mbYes, mbNo], 0) = mrNo then
      exit;
    SaveCursor := screen.cursor;
    screen.cursor := crHourGlass;
    aAccess := OpenDialog1.FileName;
    TempName := ChangeFileExt(aAccess, '.$$$');
    DeleteFile(PChar(TempName));
    JetEngine := CreateOleObject('JRO.JetEngine');
    try
      JetEngine.CompactDatabase(Format(stAccessDB, [aAccess]),
        Format(stAccessDB, [TempName]));
      DeleteFile(PChar(aAccess));
      RenameFile(TempName, aAccess);
    finally
      JetEngine := Unassigned;
      screen.cursor := SaveCursor;
    end;
  end;
end;

Important Notes:
Include the JRO_TLB unit in your uses clause.
Nobody should use or open the database during compacting.
If the compiler gives you an error on the JRO_TLB unit follow these steps:
Using the Delphi IDE go to Project &#8211; Import Type Library.
Scroll down until you reach &#8220;Microsoft Jet and Replication Objects 2.1 Library&#8221;.
Click on Install button.
Recompile a gain.

How to make a TCollectionItem contain a TCollection

Problem/Question/Abstract:

I would like to create a component that contains a TCollection with TCollectionItems. Then I want to contain another TCollection with TCollectionItems within the TCollectionItems. I am trying to create a collection of sections, which would contain a collection of items for each section.

Answer:

It's not difficult to implement such functionality. One thing you need to care about is the valid Owner for your collections, presumably, the main control would be the best choice. Below is an example of such a component:


{ ... }
type
  TYourCollectionItem = class;
  TYourCollection = class;
  TColControl = class;

  TYourCollectionItem = class(TCollectionItem)
  protected
    FFirstString: string;
    FChildCollection: TYourCollection;
    procedure SetIndex(Value: Integer); override;
    function GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property FirstString: string read FFirstString write FFirstString;
    property ChildCollection: TYourCollection read FChildCollection write
      FChildCollection;
  end;

  TYourCollection = class(TOwnedCollection)
  protected
    function GetItem(Index: Integer): TYourCollectionItem;
    procedure SetItem(Index: Integer; Value: TYourCollectionItem);
  public
    constructor Create(AOwner: TPersistent);
    property Items[Index: Integer]: TYourCollectionItem read GetItem write SetItem;
  end;

  TColControl = class(TComponent)
  protected
    FCollection: TYourCollection;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Collection: TYourCollection read FCollection write FCollection;
  end;

  { ... }

constructor TYourCollectionItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FChildCollection := TYourCollection.Create(Collection.Owner);
end;

destructor TYourCollectionItem.Destroy;
begin
  FChildCollection.Free;
  inherited Destroy;
end;

procedure TYourCollectionItem.SetIndex(Value: Integer);
begin
  inherited SetIndex(Value);
  ShowMessage(IntToStr(Value));
end;

function TYourCollectionItem.GetDisplayName: string;
begin
  Result := FFirstString;
end;

procedure TYourCollectionItem.Assign(Source: TPersistent);
begin
  FFirstString := TYourCollectionItem(Source).FFirstString;
  FChildCollection.Assign(TYourCollectionItem(Source).ChildCollection);
end;

constructor TYourCollection.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner, TYourCollectionItem);
end;

function TYourCollection.GetItem(Index: Integer): TYourCollectionItem;
begin
  Result := TYourCollectionItem(inherited GetItem(Index));
end;

procedure TYourCollection.SetItem(Index: Integer; Value: TYourCollectionItem);
begin
  inherited SetItem(Index, Value);
end;

constructor TColControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCollection := TYourCollection.Create(Self);
end;

destructor TColControl.Destroy;
begin
  FCollection.Free;
  FCollection := nil;
  inherited Destroy;
end;

How to detect if a CD has been inserted or removed into/ from a drive

Problem/Question/Abstract:

How to detect if a CD has been inserted or removed into/ from a drive

Answer:

{ ... }
type
  TForm1 = class(TForm)
  private
    { private declarations }
    procedure WMDeviceChange(var Msg: TMessage); message WM_DeviceChange;
  public
    { public declarations }
  end;

procedure TForm1.WMDeviceChange(var Msg: TMessage);
const
  DBT_QUERYCHANGECONFIG = $0017;
  DBT_CONFIGCHANGED = $0018;
  DBT_CONFIGCHANGECANCELED = $0019;
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEQUERYREMOVE = $8001;
  DBT_DEVICEQUERYREMOVEFAILED = $8002;
  DBT_DEVICEREMOVEPENDING = $8003;
  DBT_DEVICEREMOVECOMPLETE = $8004;
  DBT_DEVICETYPESPECIFIC = $8005;
  DBT_USERDEFINED = $FFFF;
var
  tmpStr: string;
begin
  inherited
    case Msg.wParam of
    DBT_DEVICEARRIVAL:
      tmpStr := 'CD inserted in drive';
    DBT_DEVICEREMOVECOMPLETE:
      tmpSTr := 'CD removed from drive';
  end;
  ShowMessage(tmpStr);
end;

How to determine what control a TPopupMenu was activated for

Problem/Question/Abstract:

How can the event handler of a popup menu item determine which component was right-clicked upon to activate that menu?

Answer:

Use the PopupMenu.PopupComponent property to determine what control the menu was activated for:


procedure TForm1.PopupItem1Click(Sender: TObject);
begin
  Label1.Caption := PopupMenu1.PopupComponent.ClassName;
end;


The form's ActiveControl property can also be used, however, the active control may not necessarily be the control that caused the popup menu to appear.

How to Use Adobe Acrobat (PDF) Files in a Delphi Application

Problem/Question/Abstract:

How to Use Adobe Acrobat (PDF) Files in a Delphi Application

Answer:

Let's see how to to show an Adobe Acrobat (.PDF) file in a Delphi application. All you need to do is the Acrobat ActiveX control (pdf.ocx and pdf.tlb), which you you can get for free from Adobe.

Here's How:

Start Delphi and select Component | Import ActiveX Control...
Look for the 'Acrobat Control for ActiveX (Version x.x)'  and simply click on Install.
Select the Component palette location in which you want to place selected library.
Maybe the best is to leave the ActiveX option selected.
Click on Install.
Select a package where the new component must be installed or create a new package for the new TPdf control.  Click on OK.
Delphi will prompt you whether you want to rebuild the modified/new package or not.  Click on Yes.
After the package is compiled, Delphi will show you a message saying that the new TPdf component was registered and already available as part of the VCL.
Close the package detail window, allowing Delphi to save the changes to it.
The component is now available in the ActiveX tab (if you didn't change this setting in step 4)  
Drop the component on a form.
Select the TPdf component you just dropped on a blank form.
Using the object inspector, set the src property to the name of an existing PDF file on your system. Now all you have to do is resize the component and read the PDF file from your Delphi application.


Tips:

If you do not have the Acrobat ActiveX control, download it now! It will be required for tip to work.
Last step (Step 15) can be done in runtime, so you can open and close files programmatically, as well as resize the control.

Closing acrobat reader on formdestroy:

procedure Tfrm_doc_pdf.FormDestroy(Sender: TObject);
var
  xHWND: integer;
begin
  xHWND := findwindow(nil, 'Acrobat Reader');
  sendmessage(xHWND, WM_CLOSE, 0, 0);
end;

Testing new component without installing it

Problem/Question/Abstract:

How can I test a component without installing it?

Answer:

If you are developing a new component, it takes a lot of time to test every change by installing the component. But there is a easier way to do this:

First, create a new project.

Then add the unit with the component's source code to the 'uses ...' line.

The last thing you have to do is to add the OnCreate event of your form an add the code as shown in the following example.

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TComponent1.Create(self) do
  begin
    Parent := self; // This makes the component visible at runtime
    {now you can define the values for other properties }
    Caption := '...';
    Left := 100;
    Top := 100;
    {...}
  end;
end;

Make a program only run once per Windows session

Problem/Question/Abstract:

How can I prevent the user from running my program twice during the same Windows session? I want to force the user to log into Windows again before my application can be started a second time.

Answer:

A way to make a program only be able to run once in every session is to create a unique global atom string on first run. Then on the following run, check if the string exists, and not run the program if the string atom is present. For example:

procedure TForm1.FormShow(Sender: TObject);
var
  atom: Integer;
begin
  if (GlobalFindAtom('This_is_some_unique_text') = 0) then
    atom := GlobalAddAtom('This_is_some_unique_text')
  else
  begin
    ShowMessage('This application can only be run once for every Windows Session.');
    Close;
  end;
end;

How to set the PixelsPerInch property of a TPrinter

Problem/Question/Abstract:

How to set the PixelsPerInch property of a TPrinter

Answer:

When changing printers, be aware that fontsizes may not always scale properly. To ensure proper scaling, set the PixelsPerInch property of the font after changing the printer index property. Be sure not to make the change until you have started the print job.

Here are two examples:

uses
  Printers;

var
  MyFile: TextFile;
begin
  Printer.PrinterIndex := 2;
  AssignPrn(MyFile);
  Rewrite(MyFile);
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps(Printer.Canvas.Handle,
    LOGPIXELSY);
  Writeln(MyFile, 'Print this text');
  System.CloseFile(MyFile);
end;

uses
  Printers;

begin
  Printer.PrinterIndex := 2;
  Printer.BeginDoc;
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps(Printer.Canvas.Handle,
    LOGPIXELSY);
  Printer.Canvas.Textout(10, 10, 'Print this text');
  Printer.EndDoc;
end;

Some useful date calculation routines

Problem/Question/Abstract:

Some useful date calculation routines

Answer:

Ever notice how some date routines are missing from SysUtils? Well as they say, necessity is the mother of invention, I've come up with some date calculation routines that you can include in your own programs that require some date calculations. If you've got any more than this, please feel free to share them!

type
  TDatePart = (dpYear, dpMonth, dpDay);

  {Purpose  : Return a date part.}

function GetDatePart(Date: TDateTime; DatePart: TDatePart): Word;
var
  D, M, Y: Word;
begin
  //Initialize Result - avoids compiler warning
  Result := 0;
  DecodeDate(Date, Y, M, D);
  case DatePart of
    dpYear: Result := Y;
    dpMonth: Result := M;
    dpDay: Result := D;
  end;
end;

{Purpose  : Extracts the date portion of a date time. Useful for
            seeing if two date time values fall on the same day}

function ExtractDatePart(Date: TDateTime): TDate;
begin
  Result := Int(Date);
end;

{Purpose  : Gets the time portion of a date time. Like ExtractDatePart
            this is useful for comparing times.}

function ExtractTimePart(Date: TDateTime): TTime;
begin
  Result := Frac(Date);
end;

{Purpose  : Used for determining whether or not a DateTime is
            a weekday.}

function IsWeekday(Day: TDateTime): Boolean;
begin
  Result := (DayOfWeek(Day) >= 2) and (DayOfWeek(Day) <= 6);
end;

{Purpose  :  Function returns the date of the relative day of a
             month/year combo such as the date of the "Third
             Monday of January." The formal parameters depart a bit
             from the MS SQL Server Schedule agent constants in that
             the RelativeFactor parameter (Freq_Relative_Interval in
             MS-SQL), takes integer values from 1 to 5 as opposed to
             integer values from 2 to the 0th to 2 to the 4th power.

Formal Parameters
======================================================================================
Year            : Year in question
Month           : Month in question
RelativeFactor  : 1 = First; 2 = Second; 3 = Third; 4 = Fourth; 5 = Last
Day             : 1 - 7, day starting on Sunday; 8 = Day;
                  9 = Weekday; 10 = Weekend Day
}

function GetRelativeDate(Year, Month,
  RelativeFactor, Day: Integer): TDateTime;
var
  TempDate: TDateTime;
  DayIndex: Integer;
begin
  TempDate := EncodeDate(Year, Month, 1);
  DayIndex := 0;
  //Now, if you're looking for the last day, just go to the last
  //day of the month, and count backwards until you hit the day
  //you're interested in.
  if (RelativeFactor = 5) then
  begin
    TempDate := EncodeDate(Year, Month, MonthDays[IsLeapYear(Year), Month]);
    case Day of
      1..7:
        if (DayOfWeek(TempDate) = Day) then
          Result := TempDate
        else
        begin
          while (DayOfWeek(TempDate) <> Day) do
            TempDate := TempDate - 1;
          Result := TempDate;
        end;
      9:
        begin
          if IsWeekday(TempDate) then
            Result := TempDate
          else
          begin
            while not IsWeekday(TempDate) do
              TempDate := TempDate - 1;
            Result := TempDate;
          end;
        end;
      10:
        begin
          if not IsWeekday(TempDate) then
            Result := TempDate
          else
          begin
            while IsWeekday(TempDate) do
              TempDate := TempDate - 1;
            Result := TempDate;
          end;
        end;
    else
      //This only happens if you're going after the very last day of the month
      Result := TempDate;
    end;
  end
  else
    //Otherwise, you have to go through the month day by day until you get
    //to the day you want. Since the relative week is a power of 2, just
    //see if the day exponent is a
    case Day of
      1..7:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if (DayOfWeek(TempDate) = Day) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      9:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
      10:
        begin
          while (DayIndex < RelativeFactor) do
          begin
            if not IsWeekDay(TempDate) then
              Inc(DayIndex);
            TempDate := TempDate + 1;
          end;
          Result := TempDate - 1;
        end;
    else
      Result := TempDate + RelativeFactor;
    end;
end;

type
  TDecimalTimeType = (dtSecond, dtMinute, dtHour);

  {Purpose  : Returns hours, minutes, or seconds in decimal format for use
              in date time calculations}

function GetDecimalTime(Count: Integer;
  DecimalTimeType: TDecimalTimeType): Double;
const
  Second = 1 / 86400;
  Minute = 1 / 1440;
  Hour = 1 / 24;
begin
  //Initialize result
  Result := 0;
  case DecimalTimeType of
    dtSecond: Result := Count * Second;
    dtMinute: Result := Count * Minute;
    dtHour: Result := Count * Hour;
  end;
end;

{Purpose  : Converts a MS-style integer time to a TTime}

function IntTimeToTime(Time: Integer): TTime;
var
  S: string;
begin
  S := IntToStr(Time);
  //String must be 5 or 6 character long
  if (Length(S) < 5) or (Length(S) > 6) then
    Result := 0
  else
  begin
    if (Length(S) = 5) then //A morning time
      S := Copy(S, 1, 1) + ':' + Copy(S, 2, 2) + ':' + Copy(S, 4, 2)
    else //Afternoon, evening time
      S := Copy(S, 1, 2) + ':' + Copy(S, 3, 2) + ':' + Copy(S, 5, 2);
    Result := StrToTime(S);
  end;
end;

How to read the value of a component property directly from its resource

Problem/Question/Abstract:

Does anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like:

if ReadPropertyValue('Form1.Button1', 'width') > 1000 then
  ShowMessage('You are about to create a big button!');

Answer:

function TForm1.ReadProp(r: TReader): string;
begin
  result := '';
  {Determine the value type of the property, read it with the appropriate method
  of TReader and convert it to string. Not all value types are implemented here
  but you get the idea.}
  case r.NextValue of
    vaInt8, vaInt16, vaInt32:
      result := IntToStr(r.ReadInteger);
    vaExtended:
      result := FloatToStr(r.ReadFloat);
    vaString:
      result := r.ReadString;
  else
    r.SkipValue; {Not implemented}
  end;
end;

procedure TForm1.ReadRes(PropPath: string; r: TReader);
var
  p: string;
begin
  {Skip the class name}
  r.ReadStr;
  {Construct the property path}
  if PropPath = '' then
    p := r.ReadStr
  else
    p := PropPath + '.' + r.ReadStr;
  {Read all properties and its values and fill them into the memo}
  while not r.EndOfList do
    Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r));
  {Skip over the end of the list of the properties of this component}
  r.CheckValue(vaNull);
  {Recursively read the properties of all sub-components}
  while not r.EndOfList do
  begin
    ReadRes(p, r);
    r.CheckValue(vaNull);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  strm: TResourceStream;
  Reader: TReader;
begin
  strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA);
  Reader := TReader.Create(strm, 1024);
  try
    Memo1.Clear;
    Reader.ReadSignature;
    ReadRes('', Reader);
  finally
    Reader.Free;
    strm.Free;
  end;
end;

Only one small problem.
r.SkipValue was protected (in D5) but I hacked that out with the following code:

type
  THackReader = class(TReader);
  { ... }
  THackReader(r).SkipValue;

And now it works like a charm.

How to eliminate flickering without using LockWindowUpdate(Handle)

Problem/Question/Abstract:

I have an application in which the user drags TImage descendants around on a background image. When an image is dropped, I have to run through all the current images finding out where they are, and then arrange their z-order appropriately. When I do this, there's significant flickering. I've tried calling LockWindowUpdate(Handle) before the operation, then LockWindowUpdate(0) at the end, but several repaint operations still seem to take place at once. I'd like to be able to repaint the whole form once only, or failing that, limit the repaint to a specific area of the form (so that all my buttons etc, which aren't involved in any of this, don't have to flicker too).

Answer:

Below is a fragment of code implementing reference counted form redraw locking. I use it in my apps where any form is derived from TLwForm (subclass of TForm). It suggests locking not limited to one window as it's the case with LockWindowUpdate. The approach can be applied not to the form as the whole but, via iteration, to all its TWinControl children.

var
  FLockFormUpdatePile: integer;

procedure TLwForm.LockFormUpdate;
begin
  if FLockFormUpdatePile = 0 then
    Perform(WM_SetRedraw, 0, 0);
  inc(FLockFormUpdatePile);
end;

procedure TLwForm.UnlockFormUpdate;
begin
  dec(FLockFormUpdatePile);
  if FLockFormUpdatePile = 0 then
  begin
    Perform(WM_SetRedraw, 1, 0);
    RedrawWindow(Handle, nil, 0, RDW_FRAME + RDW_INVALIDATE +
      RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
  end;
end;

How to determine the width of a TMainMenu

Problem/Question/Abstract:

How do I determine the width of a TMainMenu? I want to ensure that the form is not resized to less than the width of the TMainMenu on the form.

Answer:

The menu bar will automatically wrap when that happens, so it is not a catastrophy. There is a GetMenuItemRect API function you may want to try to get the information you are after.

procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
  i: Integer;
begin
  for i := 0 to mainmenu1.Items.Count - 1 do
  begin
    Win32Check(GetMenuItemrect(handle, mainmenu1.handle, i, r));
    memo1.lines.add(format('Item %d: (%d, %d), (%d, %d)', [i, r.left, r.top, r.right,
      r.bottom]));
  end;
end;

Note that the coordinates returned are screen-coordinates.

Capture text from another non-Delphi application window

Problem/Question/Abstract:

I need to capture the text from a scrolling text window in another program that I don't have access to only through a window handle. Can I use SendMEssage or something to ge the text with WM_GETTEXT type message. I know there are programs like spell checkers that can do this. Any help would be appreciated.

Answer:

Solve 1:

The example runs 'chkdsk.exe c:\' and displays the output to Memo1. Put a TMemo (Memo1) and a TButton (Button1) on your form. Put this code in the OnCLick of Button1:

procedure TForm1.Button1Click(Sender: TObject);

  procedure RunDosInMemo(DosApp: string; AMemo: TMemo);
  const
    ReadBuffer = 2400;
  var
    Security: TSecurityAttributes;
    ReadPipe, WritePipe: THandle;
    start: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer: Pchar;
    BytesRead: DWord;
    Apprunning: DWord;
  begin
    with Security do
    begin
      nlength := SizeOf(TSecurityAttributes);
      binherithandle := true;
      lpsecuritydescriptor := nil;
    end;
    if Createpipe(ReadPipe, WritePipe, @Security, 0) then
    begin
      Buffer := AllocMem(ReadBuffer + 1);
      FillChar(Start, Sizeof(Start), #0);
      start.cb := SizeOf(start);
      start.hStdOutput := WritePipe;
      start.hStdInput := ReadPipe;
      start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
      start.wShowWindow := SW_HIDE;
      if CreateProcess(nil, PChar(DosApp), @Security, @Security, true,
        NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo) then
      begin
        repeat
          Apprunning := WaitForSingleObject(ProcessInfo.hProcess, 100);
          Application.ProcessMessages;
        until
          (Apprunning <> WAIT_TIMEOUT);
        repeat
          BytesRead := 0;
          ReadFile(ReadPipe, Buffer[0],
            ReadBuffer, BytesRead, nil);
          Buffer[BytesRead] := #0;
          OemToAnsi(Buffer, Buffer);
          AMemo.Text := AMemo.text + string(Buffer);
        until
          (BytesRead < ReadBuffer);
      end;
      FreeMem(Buffer);
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
      CloseHandle(ReadPipe);
      CloseHandle(WritePipe);
    end;
  end;

begin {Button1 code}
  RunDosInMemo('chkdsk.exe c:\', Memo1);
end;

Unfortunaly that will only work with applications that send output to stdout. A Windows application usually doesn't do this.


Solve 2:

The usually use different techiques, like OCR on a screen bitmap. There is simply no generic method to get text from other windows. What you can try, however, is this:

function GetTextFromWindow(wnd: HWND): string;
var
  count: Cardinal;
begin
  result := '';
  if SendMessageTimeout(wnd, WM_GETTEXTLENGTH, 0, 0,
    SMTO_ABORTIFHUNG, 1000, count) <> 0 then
  begin
    if count = 0 then
      Exit;
    SetLength(result, count);
    if SendMessageTimeout(wnd, WM_GETTEXT, count + 1, lparam(@result[1]),
      SMTO_ABORTIFHUNG, 1000, count) = 0 then
      result := '';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wnd: HWND;
begin
  wnd := FindWindow('notepad', nil);
  if wnd <> 0 then
  begin
    wnd := GetWindow(wnd, GW_CHILD);
    if wnd <> 0 then
      memo1.text := GetTextfromwindow(wnd);
  end
  else
    memo1.text := 'Notepad not running.';
end;

Change the font properties of a certain row or column in a TStringGrid

Problem/Question/Abstract:

How to change the font properties of a certain row or column in a TStringGrid

Answer:

You can do it by handling the OnDrawCell event.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  StringGrid1.Canvas.FillRect(Rect);
  if ARow = 1 then {Use ACol for column or use both for a cell}
  begin
    StringGrid1.Canvas.Font.Color := clBlue;
    StringGrid1.Canvas.Font.Name := 'Tahoma';
    StringGrid1.Canvas.Font.Style := StringGrid1.Canvas.Font.Style + [fsBold];
  end;
  DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol, ARow]), -1,
    Rect, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
end;

Change fonts between columns in a TStringGrid (2)

Problem/Question/Abstract:

How can I code the Fixed Row in Bold (font) style whereas Normal Rows in Normal style for TStringGrid component?

Answer:

You need to handle the OnDrawCell event.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  Fmt: integer;
begin
  StringGrid1.Canvas.FillRect(Rect);
  {set bold for fixed cells, also set alignment}
  if gdFixed in State then
  begin
    StringGrid1.Canvas.Font.Style := [fsBold];
    Fmt := DT_SINGLELINE or DT_VCENTER or DT_CENTER;
  end
  else
    Fmt := DT_SINGLELINE or DT_VCENTER or DT_LEFT;
  DrawText(StringGrid1.Canvas.Handle, PChar(StringGrid1.Cells[ACol, ARow]), -1, Rect,
    Fmt);
end;

How to make a form non-moveable

Problem/Question/Abstract:

How to make a form non-moveable

Answer:

It is easy to make a form non-moveable.
Choose a borderstyle like bsDialog so that the window can not be resized.

Then add an handler for the WM_WINDOWPOSCHANGING message and override the change.


type
  TMyForm = class(TForm)
  protected
    procedure OnPosChange(var Msg: TWmWindowPosChanging); message
      WM_WINDOWPOSCHANGING;
  end;

procedure TForm1.OnPosChange(var Msg: TWmWindowPosChanging);
begin
  Msg.WindowPos.x := Left;
  Msg.WindowPos.y := Top;
  Msg.Result := 0;
end;

Counting occurrences in a string

Problem/Question/Abstract:

A function that returns the number of times a substring occurs in a string. There's also an ANSI version.

Answer:

The following functions return the number of occurrences of a char or a substring within a string or ANSI string:

interface

function Occurs(const str: string; c: char): integer; overload;
function Occurs(const str: string; const substr: string): integer;
overload;
function AnsiOccurs(const str: string; const substr: string): integer;

implementation

uses sysutils;

function Occurs(const str: string; c: char): integer;
// Returns the number of times a character occurs in a string
var
  p: PChar;
begin
  Result := 0;
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := StrScan(p, c);
    if p <> nil then
    begin
      inc(Result);
      inc(p);
    end;
  end;
end;

function Occurs(const str: string; const substr: string): integer;
// Returns the number of times a substring occurs in a string
var
  p, q: PChar;
  n: integer;
begin
  Result := 0;
  n := Length(substr);
  if n = 0 then
    exit;
  q := PChar(Pointer(substr));
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := StrPos(p, q);
    if p <> nil then
    begin
      inc(Result);
      inc(p, n);
    end;
  end;
end;

function AnsiOccurs(const str: string; const substr: string): integer;
// Returns the number of times a substring occurs in a string
// ANSI version
var
  p, q: PChar;
  n: integer;
begin
  Result := 0;
  n := Length(substr);
  if n = 0 then
    exit;
  q := PChar(Pointer(substr));
  p := PChar(Pointer(str));
  while p <> nil do
  begin
    p := AnsiStrPos(p, q);
    if p <> nil then
    begin
      inc(Result);
      inc(p, n);
    end;
  end;
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

How to check if the mouse cursor is outside a TForm

Problem/Question/Abstract:

How can I find out if the cursor is leaving a Delphi form?

Answer:

Solve 1:

Add a handler for the CM_MOUSELEAVE message to the form:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
  private
    { Private declarations }
    procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMMouseEnter(var msg: TMessage);
begin
  if msg.lparam = 0 then
    memo1.Lines.add('Entered ' + Name)
  else
    memo1.Lines.add('Entered ' + TControl(msg.lparam).Name);
end;

procedure TForm1.CMMouseLeave(var msg: TMessage);
begin
  if msg.lparam = 0 then
    memo1.Lines.add('Left ' + Name)
  else
    memo1.Lines.add('Left ' + TControl(msg.lparam).Name);
end;

end.


Solve 2:

Place the following code in your form's OnMouseMove event handler, and you'll see SetCapture/ ReleaseCapture in action (plus its side-effects):

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if (GetCapture < > Handle) then {OnMouseEnter}
  begin
    Beep;
    Caption := 'Hello';
    SetCapture(Handle);
  end
  else if (PtInRect(ClientRect, Point(X, Y))) then {OnMouseOver}
    Caption := 'X=' + IntToStr(X) + ':Y=' + IntToStr(Y)
  else {OnMouseOut}
  begin
    Beep;
    Caption := 'Goodbye!';
    ReleaseCapture;
  end;
end;

How to remove the title bar of a MDI child form

Problem/Question/Abstract:

I want the form only to appear once on the user's desktop regardless of whether it has focus or not.

Answer:

Solve 1:

type
  TForm2 = class(TForm)
    {other stuff above}
    procedure CreateParams(var Params: TCreateParams); override;
    {other stuff below}
  end;

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER
end;


Solve 2:

For a MDI child form, setting the BorderStyle to bsNone does not remove the title bar. This does it:

procedure tMdiChildForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and (not WS_CAPTION);
end;

How to get a list of the applications that will appear on the Windows Taskbar

Problem/Question/Abstract:

I am trying to get a list of the windows that will appear on the Taskbar (and perhaps on Alt-Tab). I have tried to find the ones with no parent windows, etc. but I cannot find the pattern.

Answer:

As far as I know it has never been explicitly documented which criteria Windows uses here. Try the following:

function EnumWindowsProc(Wnd: HWND; LParam: LPARAM): BOOL; stdcall;
begin
  Result := True;
  if (IsWindowVisible(Wnd) or IsIconic(wnd)) and
    ((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
    (GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and
    { skip WS_EX_TOOLWINDOW windows }
  (GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then
  begin
    { place code here }
  end;
end;

How to set tabstops in a TRichEdit

Problem/Question/Abstract:

How can I set the positions for tabstops in general? I mean, they should be active when a new TRichEdit is opened or when an open TRichEdit is filled with text via LoadFromFile. I tried it with paragraph.tab but it doesn't do what I want.

Answer:

The property is somewhat screwed up, best use the API way directly: The positions need to be specified in twips (1/1440 inch) for the EM_SETPARAFORMAT message. The following method sets tabstops every 5 average character positions, based on the current paragraphs font.

procedure TForm1.Button2Click(Sender: TObject);
const
  tabs: array[0..5] of Integer = (5, 10, 15, 20, 25, 30);
  teststring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
var
  pf: TParaFormat;
  i: Integer;
  charwidth: Integer;
begin
  FillChar(pf, sizeof(pf), 0);
  pf.cbSize := SizeOf(pf);
  pf.dwmask := PFM_TABSTOPS;
  pf.cTabCount := 6;
  Canvas.Font.Assign(richedit1.SelAttributes);
  {average charwidth in twips}
  charwidth := (Canvas.TextWidth(teststring) * 1440) div (Screen.PixelsPerInch *
    Length(teststring));
  for i := 0 to High(tabs) do
    pf.rgxTabs[i] := tabs[i] * charwidth;
  if richedit1.perform(EM_SETPARAFORMAT, 0, Integer(@pf)) = 0 then
    ShowMessage('Failed');
end;

Add the Richedit unit to your Uses clause. If you do this setting on an empty richedit control it will become the default for new text entered. If you read in formatted text you would have to do a selectAll, then set the tabstops,to make them effective for the loaded text.

How to remove characters from a string

Problem/Question/Abstract:

We need a workable function that can strip embedded characters (single qoutes, double quotes, etc.,) from within string vars.

Answer:

Solve 1:

Here is a general method to remove characters from a string:


type
  TCharSet = set of Ansichar;

procedure RemoveCharacters(var S: AnsiString; const characters: TCharset);
var
  i: Integer;
begin
  for i := Length(S) downto 1 do
    if S[i] in characters then
      delete(S, i, 1);
end;


In your case you would call it as:


RemoveCharacters(aString, [' ']);


There are certainly faster ways to implement this but unless you call the procedure some ten-thousand times in a loop I would not worry about that.


Solve 2:

function RemoveCharsFromString(const TheString: string; const CharsToRemove: array
  of Char): string;
var
  i:
  Integer;
begin
  Result := TheString;
  for i := Low(CharsToRemove) to High(CharsToRemove) do
  begin
    Result := StringReplace(Result, CharsToRemove[i], '', [rfReplaceAll]);
  end;
end;


Solve 3:

type
  TSetOfChar = set of char;

function RemoveCharsFromString(const TheString: string;
  const CharsToRemove: TSetOfChar): string;
var
  i, j: Integer;
begin
  SetLength(Result, length(TheString));
  j := 0;
  for i := 1 to length(TheString) do
  begin
    if not (TheString[i] in CharsToRemove) then
    begin
      inc(j);
      Result[j] := TheString[i];
    end;
  end;
  SetLength(Result, j);
end;

Get the correct height of a TDBText

Problem/Question/Abstract:

I have a TDBText with WordWrap = True and it is anchored to the left and right of the form. As the form resizes, the height of the TDBText changes. Is there any way of knowing the height of the TDBText? TDBText.Height doesn't return the correct value.

Answer:

TDBText is a descendant of TCustomLabel, so this should work:

{ ... }
type
  TLabelCracker = class(TCustomLabel)
  end;

function LabelTextHeight(ALabel: TCustomLabel): Integer;
const
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  Rect: TRect;
begin
  Rect := ALabel.ClientRect;
  TLabelCracker(ALabel).DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT) or
    WordWraps[TLabelCracker(ALabel).WordWrap]);
  Result := Rect.Bottom - Rect.Top;
end;