Detect and download a new version

Problem/Question/Abstract:

How can I detect and download a new version of my applications.

Answer:

{Well first you need a home page or a server and then you must use the following source code}

uses URLMON, INIFILES;
{This will download the necesary files}

function DownloadFile(Source, Dest: string): Boolean;
begin
  try
    Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0;
  except
    Result := False;
  end;
end;

function GetPathPath: string;
begin
  Result := ExtractFilePath(Paramstr(0)); //This get's the path
end;
{You need to set up on your server a ini file called update.ini containing the following lines}

[version]
wsc=6

then apply this source code:

var
  apath: string;
  new: Integer;
begin
  apath := GetPathPath;
  Gauge1.Progress := 0;
  StatusBar1.SimplePanel := True;
  StatusBar1.SimpleText := 'Connecting to http://tsoft.home.ro';
  Gauge1.Progress := 20;
  if DownloadFile('http://www.tsoft.home.ro/update.ini', PChar(apath) + '/update.ini')
    then
  begin
    Gauge1.Progress := 50;
    StatusBAr1.SimplePanel := True;
    StatusBar1.SimpleText := 'Checking for newer versions...';
    vernfo := TiniFile.Create(GetPathPath + '/update.ini');
    new := vernfo.ReadInteger('version', 'wsc', 6);
    vernfo.Free;
    if (old = new) then
    begin
      StatusBar1.SimplePanel := True;
      StatusBar1.SimpleText := 'No new version detected';
      Gauge1.Progress := 100;
    end
    else if DownloadFile('http://www.tsoft.home.ro/winnew.exe', PChar(apath) +
      '/winsafe.exe') then
    begin
      ShowMessage('Update succeseful');
      Gauge1.Progress := 100;
      winsc := TIniFile.Create(ChangeFileExt(Application.ExeName, '.ini'));
      winsc.WriteInteger('wsc', 'vernfo', new);
      winsc.Free;
    end
    else
      MessageDlg('A new version has appeard but it requires a second istall!',
        mtInformation, [mbOk], 0);
  end
  else
  begin
    StatusBAr1.SimplePanel := True;
    StatusBar1.SimpleText := 'Failed probably a internet problem';
    Gauge1.Progress := 0;
  end;
end;
{You will figure it out coz you can't copy the code like this you must make a few adjustments but I provided the ideea}

Microsoft automation: dataset export and printing

Problem/Question/Abstract:

There are many ways one can view the Automation. The most pragmatic one is the following: parts of your application already exist on the client’s machine. Writing them again is a waste of time. Creating a new program is maybe like creating the universe, but the privilege to start from scratch every time is reserved only for God. Using Microsoft Automation, though, is almost as exciting: a lot of hidden surprises and riffs are waiting for you and sometimes the only way forward is to experiment. If you have enough perserverance to cope with the constantly changing Microsoft environment, success will come to you – a truth, which is applicable not only to programming …

Answer:

Delphi 5 makes the task perhaps slightly easier: a set of nice server components are on the palette. It is up to you if you want to use them or not, but you should be aware of one important thing: they are not real Delphi components. An imported type library is hidden behind them and often is very useful to know which one it is.

The Office 2000 object model is different from the Office 97 one. As my experience shows it is still more advisable to use the older library. Otherwise, you have to make sure that all your clients have Office 2000 installed. Moreover, it is easy to “rewrite” the server components only in a few minutes: remove the package and import the desired library into a new one. In my case I use the Excel 97 library. I have tested it in Office 2000 environment with no problems.

As s for components it is just more convinient to use them instead of calling the interfaces directly. The wrapper is too thin to disturb the performance but if you have concerns you can combine both approaches. Sometimes even using Variants is unavoidable .

CELL BY CELL

Automating Excel is one of the most efficient ways to have a DBGrid or a Dataset printed. It is easy to import data to Excel and the options for formatting, adding calculated fields, summaries or even charts are almost unlimited. Excel can be a very powerfull report generator for any application.

The most obvious approach is to fill the Excel worksheet as a stringgrid: cell by cell. The field datatype and even the value for each cell can be checked during this operation and formatted accordingly.

The first task is to connect to a new Excel worksheet. I use 3 components to accomplish this:

Excel: TExcelApplication;
Worksheet: TExcelWorksheet;
Workbook: TExcelWorkbook;

This follows the logics of the Excel’s object model. Theoretically, you should be able to connect the worksheet component directly . In practice even using the three components can be problematic: you can not connect the worksheet before opening the workbook and at least on my machine every attempt to open a workbook would cause an error. Thanks to Deborah Pate I already know how to prevent this:

Excel.Connect;
lcid := GetUserDefaultLCID;
Workbook.ConnectTo(Excel.Workbooks.Add(TOleEnum(xlWBATWorksheet), lcid);
Worksheet.ConnectTo(Workbook.Worksheets[1] as _Worksheet);

Now the new worksheet is ready for filling. If you wold like to see it at this point, add

Excel.Visible[lcid] := True;

But in this case, you will gain some speed defining

Excel.ScreenUpdating[lcid] := False;

As I have already mentioned, accessing the cells is as in TStringGrid. Here is the whole process:

with ds do
begin
  DisableControls;
  //The first row is for the titles:
  for i := 1 to ds.FieldCount do
    if ds.Fields[i - 1].Visible then
    begin
      Worksheet.Cells.Item[1, i].Value :=
        ds.Fields[i - 1].DisplayLabel;

      Worksheet.Cells.Item[1, i].ColumnWidth :=
        ds.Fields[i - 1].DisplayWidth;
    end;
  //Some special formatting for the whole title’s row:
  Worksheet.Range['A1', 'A1'].EntireRow.Interior.Color := clGray;
  Worksheet.Range['A1', 'A1'].Font.FontStyle := 'Bold';

  L := 2;

  FIRST;
  while not (EOF) do

  begin
    for i := 1 to ds.FieldCount do
      if ds.Fields[i - 1].Visible then
      begin
        //Some special conditions for specific fields; additional formatting
        or checks could be added here
          if GetLookUpTableName(ds.Fields[i - 1].FieldName, sTable) then
          Worksheet.Cells.Item[L, i].Value :=
            GetLookUpValue(sTable, ds.Fields[i - 1].Text)
        else
          Worksheet.Cells.Item[L, i].Value :=
            ds.Fields[i - 1].Text;

      end;
    Inc(L);
    NEXT;
  end;
end;

Now turn on the screen updating and you will see the worksheet. It is formatted according to your preferences and can contain a large amount of data ( I have tested a table with 134 fields and several thousands records). But I do not recommend exporting data like this if you have a lot of records.

TEXT FILE MEDIATION

Excel 2000 workbook have a new method – OpenText – which loads and parses a text file as a new workbook with a single sheet that contains the parsed text-file data. But even in Excel 97, if you have the Tab character as a delimiter, your text will be recognized and parsed by the Open method in similar way.

It is faster than filling the worksheet cell by cell. Possible disadvantage is that the formatting has to be separated from the export. If you want to format any specific field, you should record and save its position during the file preparation. It is easy to process formatting after the worksheet is prepared if you have the coordinates of the field saved.

Next I use variants to access the workbook and the worksheet objects and the TExcelAplication component:

//After exporting the Dataset to a Tab-delimited text file and closing this file:

Excel.Connect;
lcid := GetUserDefaultLCID;
WbK := Excel.Workbooks.Open(tFileName, EmptyParam, EmptyParam,
  EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
  EmptyParam, EmptyParam, EmptyParam, EmptyParam, lcid);
ws := wbk.worksheets[1];
Excel.Visible[lcid] := True;
ws.activate;

THE POWERFULL CLIPBOARD

The Delphi huge string prompts another approach: replacing the text file with only one string, opening an empty worksheet and posting this string onto it. Excel wisely behaves similary and arranges the cells by itself according to the Tab and Enter delimiters. This approach is safer since the file routines are being avoided and it is even faster:

procedure TModule.PrintGrid3(ds: TDataSet; Header: string);

var
  S: AnsiString;
  VisCol, L, i: Integer;
  sTable: string;

begin
  with ds do
  begin
    DisableControls;

    for i := 0 to ds.FieldCount - 1 do
      if ds.Fields[i].Visible then
      begin
        S := S + ds.Fields[i].DisplayLabel;
        if i <> ds.FieldCount - 1 then
          S := S + #9;
        Inc(VisCol);
      end;
    S := S + #13;

    FIRST;
    while not (EOF) do
    begin
      for i := 0 to ds.FieldCount - 1 do
        if ds.Fields[i].Visible then
        begin
          S := S + ds.Fields[i].Text {+ #9};
          if i <> ds.FieldCount - 1 then
            S := S + #9;
          Inc(L);
        end;
      S := S + #13;
      NEXT;
    end;

      // Now copy the string :
      Clipboard.SetTextBuf(PChar(S);

      //Connect Excel:
      Excel.Connect;
      lcid := GetUserDefaultLCID;
      Workbook.ConnectTo(Excel.Workbooks.Add(TOleEnum(xlWBATWorksheet), lcid));
      Worksheet.ConnectTo(Workbook.Worksheets[1] as _Worksheet);
      Worksheet.Name := 'MyData';

      //Paste the string and clear the memory:
      Worksheet.Cells.Item[1, 1].Select;
      Worksheet.Paste;
      Clipboard.Clear;

That is it.The result is the same: your data is on place. Next lines show how to generate a ready for printing report from it and to present the PrintPreview form on the screen of your client:

                        //Formating column widths without any calculations:
                  Worksheet.Columns.AutoFit;
                        //Column titles:
                        Worksheet.Range['A1', 'A1'].EntireRow.Interior.Color := clGray;
                        Worksheet.Range['A1', 'A1'].EntireRow.HorizontalAlignment := 1;
                        Worksheet.Range['A1', 'A1'].Font.FontStyle := 'Bold';
                        Worksheet.PageSetup.PrintGridlines := true;
                        //Header and footer:
                        Worksheet.PageSetup.CenterHeader := Header;
                        Worksheet.PageSetup.LeftFooter := &#8216;Some Text&#8217;;
                        Worksheet.PageSetup.FirstPageNumber := 1;
                        Excel.Visible[lcid] := True;
                        Worksheet.PrintOut(EmptyParam, EmptyParam, 1, 1);
                        Excel.ScreenUpdating[lcid] := True;
                        Workbook.Close(False);
end;

Of course, you could just print the report without showing the preview (see the PrintOut method parameters) or proceed in a different direction: sending the data by fax or e-mail or exporting it again, using now the Excel capacities for data processing. Word is also applicable for dataset export and printing (the TextToTable method) but Excel copes better with large datasets. It is worth experimenting with various solutions in order to reach the best result.

With every new version the Office applications are going to be more and more complex. New objects, methods and properties are being added and there are already so many different capacities that even the Office creators would perhaps find it hard hard to simply count them. It is a strenuous task for the common user to learn them all. But Microsoft Office is charged with much useful building material for the inventive developer and Automation is the key for taking advantage of it.

Related resources

Charlie Calvert: Delphi 4 Unleashed
MS Excel.how by Gary White, dBVIPS
Automating Microsoft Excel : Sources of information, Sample project, How do I and Common problems by Deborah Pate.

Intercepting Windows messages in non-visual components

Problem/Question/Abstract:

Sometimes we need a non-windowed component (i.e. one that isn't derived from TWinControl) to receive Windows messages - but non-windowed component don't have window handles. For example suppose we are developing a non-visual component that registers our application as a clipboard viewer so the application can respond to changes in the clipboard. To get information about clipboard changes our component needs to receive messages from Windows.

Answer:

The Delphi library function AllocateHWnd is used to create a hidden window for us and the related DeallocateHWnd disposes of the window when we've finished with it.

The hidden window needs a window procedure. We can use a method of our component class to provide the window procedure. AllocateHWnd takes a reference to the method its parameter - it takes care of the problem of registering the method as a window procedure for us. In the method we handle the messages we are interested in and hand the rest off to Windows using the DefWindowProc API call.

The following code gives the skeleton of how to use AllocateHWnd. First, here's the class declaration from the interface section of code:

type
  // Our class derived from TComponent
  // (or another ancestor class)
  TMyClass = class(TComponent)
  private
    FHWnd: HWND;
    // field to store the window handle
  {...}
  protected
    procedure WndMethod(var Msg: TMessage); virtual;
    // the window proc - called by Windows to handle
    // the given message
  {...}
  public
    constructor Create(AOwner: TComponent); override;
    // create window proc here
    destructor Destroy; override;
    // free window proc here
  {...}
  end;

And here's the implementation details:

TMyClass.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  {... }
  // Create the window
  FHWnd := AllocateHWnd(WndMethod);
  { ...}
end;

TMyClass.Destroy;
begin
  {...}
  // Destroy the window
  DeallocateHWnd(FHWnd);
  {...}
  inherited Destroy;
end;

TMyClass.WndMethod(var Msg: TMessage);
var
  Handled: Boolean;
begin
  // Assume we handle message
  Handled := True;
  case Msg.Msg of
    WM_SOMETHING: DoSomething;
    // Code to handle a message
    WM_SOMETHINGELSE: DoSomethingElse;
    // Code to handle another message
  {...}
  else
    // We didn't handle message
    Handled := False;
  end;
  if Handled then
    // We handled message - record in message result
    Msg.Result := 0
  else
    // We didn't handle message
    // pass to DefWindowProc and record result
    Msg.Result := DefWindowProc(FHWnd, Msg.Msg,
      Msg.WParam, Msg.LParam);
end;

Of course, we could just use the Windows API to create a window the hard way and provide a windows procedure. But it is more difficult to use a method (rather than a simple procedure) as a window procedure if we do it this way. The clever features about AllocateHWnd are that (a) it creates the hidden window for us and (b) it allows us to use a method, rather than a simple procedure as the window procedure -- and a method is more useful since it has access to the class's private data.


Component Download: http://www.delphidabbler.com/download.php?file=pjcbview.zip

Find a constant dynamically

Problem/Question/Abstract:

In my application, the user has a form where he is selecting from a list of options. That list of options corresponds to contant values. Is there a way to find the value of a constant when all you have is a string containing its name?

Example:

const
  TEST = 5;
  DELIVERED = 10
    { ... }

sChoice := listboxChoice.Text // -possible values are TEST and DELIVERED
iChoice = {missing method}(sChoice)

iChoice would be assigned the value of the constant of the same name as the user's selection. No, I can't change the declarations to be enumerated types or anything else. They have to be constants. I've seen examples of this sort of thing done for Enumerated types, objects and so on using RTTI. But I can't find an example of constants, and I can't figure it out.

Answer:

Solve 1:

If enumerations are okay (I don't see how you could use names of constants), try this to get mapping of enumeration from string to integer:

{ ... }
type
  TConstValues = (cvTest, cvDelivered);

var
  values = array[TConstValues] of integer = (5, 10);
  strings = array[TConstValues] of string = ('TEST', 'DELIVERED');

  { ... }

function GetConstValue(s: string): integer;
var
  t: TConstValues;
begin
  result := -1;
  for t := low(TConstValues) to high(TConstvalues) do
    if strings[t] = s then
    begin
      result := values[t];
      break;
    end;
end;


Solve 2:

This is a modification of Solve 1:

{ ... }
const
  TCVals: array[TConstValues] of integer = (-1, 5, 10);
  TCStrs: array[TConstValues] of string = ('UNKNOWN', 'TEST', 'DELIVERED');
  { ... }

function GetConstValue(s: string): integer;
var
  t: TConstValues;
begin
  t := high(TConstvalues);
  while (t > low(TConstValues)) and (CompareText(TCStrs[t], s) <> 0) do
    dec(t);
  Result := TCVals[t];
end;

Hidden features of the Delphi IDE

Problem/Question/Abstract:

Hidden features of the Delphi IDE

Answer:

Some undocumented registry settings of Delphi 5 (which -slightly adapted- might also work with Delphi 4 and below) modify the behavior of the Delphi component palette in a manner you may like!
Most values are stored as strings, and boolean values are represented as "1" for true and "0" for false. All values are stored in

HKEY_CURRENT_USER

As always, use of this information is at your own risk... ;-)

Software\Borland\Delphi\5.0\Extras\AutoPaletteSelect

will cause a tab on the component palette to be automatically selected when the mouse is hovering over it. If the mouse is in the top two- thirds (2/3) of the tab, the palette for that tab will automatically be displayed.

Software\Borland\Delphi\5.0\Extras\AutoPaletteScroll

will make you scroll left and right automatically whenever the mouse is positioned over the relevant arrow.

Software\Borland\Delphi\5.0\Editor\Options\NoCtrlAltKeys

Disables menu item Ctrl+Alt key sequences for international keyboards

Software\Borland\Delphi\5.0\Form Design\AlwaysEnableMiddleEast

Forces Right-to-Left text in the form designer (?)

Software\Borland\Delphi\5.0\Extras\FontNamePropertyDisplayFontNames

Display the fonts in the object inspector dropdown in the font's actual style (slow with many fonts installed). See also DsgnIntf.FontNamePropertyDisplayFontNames in D5.

Software\Borland\Delphi\5.0\Compiling\ShowCodeInsiteErrors

Show compilation errors found by CodeInsite in the message view window

Software\Borland\Delphi\5.0\Globals\PropValueColor

Fill in with a string like "clGreen" to change the color of the right half (properties) of the Object Inspector.

Software\Borland\Delphi\5.0\Disabled Packages

This is the place you put Delphi Direct :)

Software\Borland\Delphi\5.0\Globals\TwoDigitYearCenturyWindow

Default value for TwoDigitYearCenturyWindow (see the help file)

Software\Borland\Delphi\5.0\Component Templates\CCLibDir

Alternative component templates directory (shared/network)

Software\Borland\Delphi\5.0\FormDesign\DefaultFont="Arial,8" [D4] or "Arial,8,Bold" [D5]

The default for for new forms (you might prefer using the repository's default form checkbox instead)

Software\Borland\Delphi\5.0\Wizards

Alternate key to store Expert/Wizard DLLs to load at startup

Software\Borland\Delphi\5.0\Debugging\DontPromptForJITDebugger

Don't ask to change the current JIT debugger (?)

Software\Borland\Delphi\5.0\Version Control\VCSManager

The DLL used for the version control interface in the IDE.

Software\Borland\Delphi\5.0\Globals\PrivateDir

A way to specify an alternative directory for the location for the Delphi configuration files when running the application from a network drive or the CD-ROM.

Software\Borland\Delphi\5.0\Main Window\Palette Visible
Software\Borland\Delphi\5.0\Main Window\Speedbar Visible
Software\Borland\Delphi\5.0\Main Window\Palette Hints
Software\Borland\Delphi\5.0\Main Window\Speedbar Hints
Software\Borland\Delphi\5.0\Main Window\Split Position

These seem to have no effect at runtime, but are read by the IDE. The actually used values come from

HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Toolbars

Software\Borland\Delphi\5.0\ProjectManager\Dockable
Software\Borland\Delphi\5.0\PropertyInspector\Dockable
Software\Borland\Delphi\5.0\CallStackWindow\Dockable
Software\Borland\Delphi\5.0\ModuleWindow\Dockable

Read but unused settings. Used values come from DSK files.

There are lots of other interesting registry keys that aren't modifiable in the IDE, but they all have values written by default, so you can find and play with them much easier.

Form as Application

Problem/Question/Abstract:

How i can create a form and this form stay in another icon in task bar ? (Looks like a new aplication).

Answer:

In private clause:

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure CreateParams(var Params: TCreateParams); override;

And, in the implementation:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with params do
    ExStyle := ExStyle or WS_EX_APPWINDOW;
end;

Invert colors in a TImage

Problem/Question/Abstract:

Is there an easy way to invert the colors in a TImage? I have a bitmap that is a black background with white text and I want it to be a white background with black text.

Answer:

Solve 1:

Ok, first we need a little theory of how an image is represented in the screen, computers use a color model in which images are represented in pixels (picture elements), each pixel can be represented with a pixel depth, in other words, the information of each pixel can be stored in diferent number of bits.

For example images with a pixel depth of 8 bits can store a maximum of 256 colors since each bit can have one of two values (0 or 1), we have 2x2x2x2x2x2x2x2 = 256.

Nowadays we have images of 24 and even 32 pixels depth, I will cover how to obtain invert the color of only this kind of images.

The RGB color model (where R=Red, G=Green, and B=Blue) threats an image of 24 pixels depth, as it is divided in 3 color chanels, where each chanel consits of 8 bits, and once again we have up to 256 posible values for each chanel, if we add the three chanels we have the final representation of the image.

Ok, enough theory, we can acomplish that with the following procedure:

procedure InvertImage(const AnImage: TImage);
var
  BytesPorScan: integer;
  vi_width, vi_height: integer;
  p: pByteArray;
begin
  //This only works with images of 24 or 32 bits per pixel
  if not (AnImage.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
    raise exception.create('Error, Format File not soported!');

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

  //Invert the RGB for each pixel
  for vi_height := 0 to AnImage.Picture.Bitmap.Height - 1 do
  begin
    P := AnImage.Picture.Bitmap.ScanLine[vi_height];
    for vi_width := 0 to BytesPorScan - 1 do
      P^[vi_width] := 255 - P^[vi_width];
  end;
  AnImage.Refresh;
end;

the important part is the for loop, since the values for each color chanel can vary from 0 to 255, whe only have to substract the actual value of the pixel (P^[vi_width) from 255 to obtain the inverse color, and assign this new value to the pixel.


Solve 2:

begin
  Image1.Canvas.CopyMode := cmDstInvert;
  Image1.Canvas.CopyRect(Image1.ClientRect, Image1.Canvas, Image1.ClientRect);
  imgZoom.Canvas.CopyMode := cmSrcCopy;
end


Solve 3:

var
  R: TRect;
begin
  { ... }
  with Image1.Picture.Bitmap do
  begin
    R := Rect(0, 0, Width, Height);
    InvertRect(Canvas.Handle, R);
  end;
  Image1.Invalidate;
  { ... }

Restrict TEdit input to floating point numbers and a defined number of decimal places

Problem/Question/Abstract:

I would like a TEdit box on my form that only accepts keys to enter a floating point number that has N number of decimal places. What is the best way to do this?

Answer:

Derive a new component from TEdit and override its KeyPress method. That is fed characters before the control has inserted them into the text. You can examine the character, reject it outright if it would not be valid for a floating point number. If it would be valid you have to examine the content of the edit, the values of SelStart and SelCount and figure out how the content would look like if you let the key pass throuogh. Test that new string against what you can accept, if it does not match you reject the key. The following OnKeyPress handler for a normal tedit control shows the logic. It should be integrated into a new component which also would have a property to set the number of allowable decimal digits.

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
const
  MAXNUMBEROFDIGITS = 2;
var
  S: string;
  val: Double;
  n: Integer;
begin
  if key <> #8 then {Always let backspace through}
    if key in ['0'..'9', '-', DecimalSeparator] then
    begin
      {key is a candidate}
      with Sender as TEdit do
      begin
        S := Text;
        if SelLength > 0 then {key will replace selection}
          Delete(S, SelStart + 1, SelLength);
        Insert(key, S, SelStart + 1);
        {S now has string as it would look after key is processed. Check if it is a valid floating point number.}
        try
          val := StrToFloat(S);
          {OK, it computes. Find the decimal point and count the digits after it.}
          n := Pos(decimalSeparator, S);
          if n > 0 then
            if (Length(S) - n) > MAXNUMBEROFDIGITS then
              {too many digits, reject key}
              key := #0;
        except
          {nope, reject key}
          key := #0;
        end;
      end;
    end
    else {key not acceptible}
      key := #0;
end;

Importing XML DOM Parser in Delphi

Problem/Question/Abstract:

How to import XML DOM Parser component in Delphi?

Answer:

One of the new features of Delphi 5 is that we can install COM servers as components in Delphi IDE. There are already some COM servers installed on the Servers Palette like Microsoft word, Excel etc., Other than that, the user can install other COM servers through the Project | Import Type library. This will create a wrapper class for that component. We can use that wrapper class to build a package in Delphi and install as component in the IDE. This is really a great and cool feature in Delphi 5.

This option will be very helpful when you want to use a COM component written in other languages. You just need to import them through this Import Type Library option. You can access the methods/properties of that COM component from Delphi 5.

I used msxml.dll(Version 2.0) to install the XML parsing components in the IDE through the Import Type Library option.

Steps to import XML DOM parser component:

Go to Project|Import Type Library(See Fig. 1. Below)
Select Microsoft XML, version 2.0(Version 2.0)
Then choose Create Unit
This will create a wrapper class for that parser in a pascal file
You can put that pascal file in a package and install it.
You will be getting a set of components installed on the ActiveX palette in Delphi
Among them will be the component called DOMDocument

Now you can use the methods of that component to parse the XML. There are some more components like OMFreeThreadedDocument,XMLHTTPRequest,XMLDSOControl and XMLDocument.

There are two ways to load the XML into that component to parse.

1. Loading the XML as a string:

You can use the &#8220;loadXML&#8221; method to load a XML string

For eg. DOMDocument.loadXML(&#8216;XML string&#8217;);

2. Loading the XML as a file:

You can use the &#8220;load&#8221; method to load a XML file.

For eg. DOMDocument.load(&#8216;Path of the XML file&#8217;)

Once you load either the XML string or the XML file into that component, the XML will be parsed and if there are any errors during parsing, then those errors will be intimated to the user by the way of exception.

You can check the place where you get the parsing error and also the reason for that.

Finding the place where the parsing error occurred:

DOMDocument.parseError.srcText will give you the exact line in the XML where the error occurred.
The above two are really helpful in diagnosing the parsing errors.

Getting the reason for the parsing error:

DOMDocument.parseError.reason will tell you the reason for that parsing error.

If there are no errors reported by the parser, then we can get the parsed data through the methods like getElementsByTagName, Get_nodeName, Get_nodeValue etc.,

The DTD file used in that XML should be in the search path of the application or should be in the path where the exe resides. Only then the application will be able to see DTD info used in that XML file or string and parse correctly.

Important:

So when we deploy an application in a fresh machine, we should not forget to include this DTD file in the same path as the exe is.
Please make sure all the XML string/XML file you are sending to that component follow the DTD mentioned in that DTD file. Even a small spelling mistake or an extra letter will cause an exception.

Extracting Version Information

Problem/Question/Abstract:

How can I display some fields from my application's version information?

Answer:

I provide you the object that could be used for extracting version information from executables and libraries.

unit siverinfo;

interface
uses Windows, Classes, SysUtils;

type
  TVersionInfo = class(TObject)
  private
    FData: Pointer;
    FSize: Cardinal;
    FCompanyName: string;
    FFileDescription: string;
    FFileVersion: string;
    FInternalName: string;
    FLegalCopyright: string;
    FLegalTrademarks: string;
    FOriginalFilename: string;
    FProductName: string;
    FProductVersion: string;
    FComments: string;
  public
    constructor Create(FileName: string);
    destructor Destroy; override;
    property CompanyName: string read FCompanyName;
    property FileDescription: string read FFileDescription;
    property FileVersion: string read FFileVersion;
    property InternalName: string read FInternalName;
    property LegalCopyright: string read FLegalCopyright;
    property LegalTrademarks: string read FLegalTrademarks;
    property OriginalFilename: string read FOriginalFilename;
    property ProductName: string read FProductName;
    property ProductVersion: string read FProductVersion;
    property Comments: string read FComments;
  end;

implementation
{ TVersionInfo }

constructor TVersionInfo.Create(FileName: string);
var
  sz, lpHandle, tbl: Cardinal;
  lpBuffer: Pointer;
  str: PChar;
  strtbl: string;
  int: PInteger;
  hiW, loW: Word;
begin
  inherited Create;
  FSize := GetFileVersionInfoSize(PChar(FileName), lpHandle);
  FData := AllocMem(FSize);
  GetFileVersionInfo(PChar(FileName), lpHandle, FSize, FData);

  VerQueryValue(FData, '\\VarFileInfo\Translation', lpBuffer, sz);
  int := lpBuffer;
  hiW := HiWord(int^);
  loW := LoWord(int^);
  tbl := (loW shl 16) or hiW;
  strtbl := Format('%x', [tbl]);
  if Length(strtbl) < 8 then
    strtbl := '0' + strtbl;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\CompanyName'), lpBuffer,
    sz);
  str := lpBuffer;
  FCompanyName := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\FileDescription'),
    lpBuffer, sz);
  str := lpBuffer;
  FFileDescription := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\FileVersion'), lpBuffer,
    sz);
  str := lpBuffer;
  FFileVersion := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\InternalName'),
    lpBuffer, sz);
  str := lpBuffer;
  FInternalName := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\LegalCopyright'),
    lpBuffer, sz);
  str := lpBuffer;
  FLegalCopyright := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\LegalTrademarks'),
    lpBuffer, sz);
  str := lpBuffer;
  FLegalTrademarks := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\OriginalFilename'),
    lpBuffer, sz);
  str := lpBuffer;
  FOriginalFilename := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\ProductName'), lpBuffer,
    sz);
  str := lpBuffer;
  FProductName := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\ProductVersion'),
    lpBuffer, sz);
  str := lpBuffer;
  FProductVersion := str;

  VerQueryValue(FData, PChar('\\StringFileInfo\' + strtbl + '\Comments'), lpBuffer,
    sz);
  str := lpBuffer;
  FComments := str;
end;

destructor TVersionInfo.Destroy;
begin
  FreeMem(FData);
  inherited;
end;

end.

Rewrite the last line of text in a text file

Problem/Question/Abstract:

How to rewrite the last line of text in a text file

Answer:

procedure RewriteLastTextLine(AFileName: string; ANewTextLine: string);
const
  BUFFER_SIZE = 1024; {change this number for different sized buffer}
  CRLF = #13#10;
var
  fs: TFileStream;
  buf: PChar;
  iStartWritePos: Int64;

  function AssignPos: Boolean;
  var
    i: Integer;
  begin
    for i := BUFFER_SIZE - 1 downto 0 do
      if (buf[i] = #13) then
      begin
        iStartWritePos := (iStartWritePos - (BUFFER_SIZE - i));
        Result := True;
        Exit;
      end;
    Result := False;
  end;

  procedure ReadABuffer;
  begin
    fs.Position := fs.Position - BUFFER_SIZE;
    fs.Read(buf^, BUFFER_SIZE);
    fs.Position := fs.Position - BUFFER_SIZE;
  end;

begin
  fs := TFileStream.Create(AFileName, fmOpenReadWrite or fmShareDenyWrite);
  try
    GetMem(buf, BUFFER_SIZE);
    FillMemory(buf, BUFFER_SIZE, 0);
    fs.Position := fs.Size;
    iStartWritePos := fs.Position;
    repeat
      ReadABuffer
    until
      AssignPos;
    fs.Position := iStartWritePos;
    fs.Write(CRLF, Length(CRLF));
    fs.Write(ANewTextLine[1], Length(ANewTextLine));
  finally
    FreeMem(buf, BUFFER_SIZE);
    fs.Free;
  end;
end;

Print a TRichEdit upside down

Problem/Question/Abstract:

How to print a TRichEdit upside down

Answer:

Below are the 4 base orientations, but TXForm (in windows.pas) gives you the ability to turn the world to any degree. World transformations are interesting in that they raise the prospect of working in code with portrait objects and simply turning the world, rather than turning the objects individually to conform to the world - which I have been doing up until now.

Note: This does not work for Win9x.

{ ... }
type
  TWorldOrientation = (woPortrait, woLandscape, woInversePortrait,
    woInverseLandscape);

function GetWorldOrientation(APageRect: TRect; AOrientation: TWorldOrientation):
  TXForm;
begin
  case AOrientation of
    woPortrait:
      begin
        Result.eM11 := 0;
        Result.eM12 := 0;
        Result.eM21 := 0;
        Result.eM22 := 0;
        Result.eDX := APageRect.Left;
        Result.eDY := APageRect.Top;
      end;
    woLandscape:
      begin
        Result.eM11 := 0;
        Result.eM12 := -1;
        Result.eM21 := 1;
        Result.eM22 := 0;
        Result.eDX := APageRect.Left;
        Result.eDY := APageRect.Bottom;
      end;
    woInversePortrait:
      begin
        Result.eM11 := -1;
        Result.eM12 := 0;
        Result.eM21 := 0;
        Result.eM22 := -1;
        Result.eDX := APageRect.Right;
        Result.eDY := APageRect.Bottom;
      end;
    woInverseLandscape:
      begin
        Result.eM11 := 0;
        Result.eM12 := 1;
        Result.eM21 := -1;
        Result.eM22 := 0;
        Result.eDX := APageRect.Right;
        Result.eDY := APageRect.Top;
      end;
  end;
end;

function PrintText(ACanvas: TCanvas; APageRect, APrintRect: TRect; AText: string;
  ATextFlags:
  Integer; AOrientation: TWorldOrientation): Boolean;
var
  SaveGM: Integer;
  SaveXF: TXForm; // unit Windows.pas
begin
  {save graphics mode}
  SaveGM := Windows.GetGraphicsMode(ACanvas.Handle);
  {can we do it}
  Result := Windows.SetGraphicsMode(aCanvas.Handle, GM_ADVANCED) <> 0;
  if Result then
  begin
    {save transform}
    Windows.GetWorldTransform(ACanvas.Handle, SaveXF);
    // set orientation
    Windows.SetWorldTransform(ACanvas.Handle, GetWorldOrientation(APageRect,
      AOrientation));
    {move text to page}
    Windows.DrawText(ACanvas.Handle, PChar(AText), -1, APrintRect, ATextFlags);
    {restore transform}
    Windows.SetWorldTransform(ACanvas.Handle, SaveXF);
    {restore graphics mode}
    Windows.SetGraphicsMode(aCanvas.Handle, SaveGM);
  end;
end;

function PrintRichText(ACanvas: TCanvas; APageRect, APrintRect: TRect; ARichEdit:
  TRichEdit;
  APixelsPerInchX, APixelsPerInchY: Integer; AOrientation: TWorldOrientation):
    Boolean;
const
  RICH_TWIPS = 1440;
var
  SaveGM: Integer;
  SaveXF: TXForm; {unit Windows.pas}
  FmtRange: TFormatRange; {unit RichEdit.pas}
begin
  {save graphics mode}
  SaveGM := Windows.GetGraphicsMode(ACanvas.Handle);
  {can we do it}
  Result := Windows.SetGraphicsMode(aCanvas.Handle, GM_ADVANCED) <> 0;
  if Result then
  begin
    {save transform}
    Windows.GetWorldTransform(ACanvas.Handle, SaveXF);
    {set orientation}
    Windows.SetWorldTransform(ACanvas.Handle, GetWorldOrientation(APageRect,
      AOrientation));
    {adjust for twips}
    APrintRect.Left := APrintRect.Left * RICH_TWIPS div APixelsPerInchX;
    APrintRect.Top := APrintRect.Top * RICH_TWIPS div APixelsPerInchY;
    APrintRect.Right := APrintRect.Right * RICH_TWIPS div APixelsPerInchX;
    APrintRect.Bottom := APrintRect.Bottom * RICH_TWIPS div APixelsPerInchY;
    {move rich text to page}
    System.FillChar(FmtRange, SizeOf(FmtRange), 0);
    FmtRange.Hdc := ACanvas.Handle;
    FmtRange.HdcTarget := ACanvas.Handle;
    FmtRange.Rc := APrintRect;
    FmtRange.ChrG.CpMin := 0;
    FmtRange.ChrG.CpMax := Length(ARichEdit.Text);
    ARichEdit.Perform(EM_FORMATRANGE, 1, LongInt(@FmtRange));
    ARichEdit.Perform(EM_FORMATRANGE, 0, 0);
    {restore transform}
    Windows.SetWorldTransform(ACanvas.Handle, SaveXF);
    {restore graphics mode}
    Windows.SetGraphicsMode(aCanvas.Handle, SaveGM);
  end;
end;

Examples:

procedure TForm1.FormCreate(Sender: TObject);
begin
  {Apparently you need to initialise before using the first time otherwise the
        canvas doesn't appear to paint properly}
  Windows.SetGraphicsMode(Self.Canvas.Handle, GM_ADVANCED);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TRect;
begin
  R := Rect(20, 20, 200, 200);
  PrintText(Self.Canvas, Self.ClientRect, R, 'I am portrait', 0, woPortrait);
  PrintText(Self.Canvas, Self.ClientRect, R, 'I am landscape', 0, woLandscape);
  PrintText(Self.Canvas, Self.ClientRect, R, 'We are inverse portrait' + #13#10 +
    'As are we', 0, woInversePortrait);
  PrintText(Self.Canvas, Self.ClientRect, R, 'We are inverse landscape.' + #13#10 +
    'Us to', DT_RIGHT, woInverseLandscape);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  R: TRect;
begin
  if OpenDialog1.Execute then
  begin
    RichEdit1.Lines.LoadFromFile(OPenDialog1.FileName);
    R := Rect(10, 10, 200, 300);
    PrintRichText(Self.Canvas, Self.ClientRect, R, RichEdit1, Screen.PixelsPerInch,
      Screen.PixelsPerInch, woPortrait);
    PrintRichText(Self.Canvas, Self.ClientRect, R, RichEdit1, Screen.PixelsPerInch,
      Screen.PixelsPerInch, woLandscape);
    PrintRichText(Self.Canvas, Self.ClientRect, R, RichEdit1, Screen.PixelsPerInch,
      Screen.PixelsPerInch, woInverseLandscape);
    PrintRichText(Self.Canvas, Self.ClientRect, R, RichEdit1, Screen.PixelsPerInch,
      Screen.PixelsPerInch, woInversePortrait);
  end;
end;

Adding custom registry information on registration

Problem/Question/Abstract:

How to add custom information to the registry at the time an ActiveX control is registered.

Answer:

There are a number of times an ActiveX control writer will wont to insert custom information into the registry when a control is registered, and then remove the information when the control is unregistered.  

For example, you often need to insert custom information into the registry if you are writing a plugin/addin for another program (Microsoft Office products all require this), or you may want to include some extra information about your control that is not put there automatically (see the article on making insertable controls).  With Visual Basic you have to make a .Reg file to do this.  Luckily, with Delphi, we can do better.

To do this you need to override the default initialization of your ActiveX control.  To do this you need to create a custom class that inherits from either TActiveFormFactory or TActiveXControlFactory depending if you are in an ActiveForm project or an ActiveX Control project.  (Note: TActiveFormFactory inherits from TActiveXControlFactory).

So, we create a new class call TMyFactory.  There is one procedure we want to override call UpdateRegistry.  It has one parameter call &#8220;Register&#8221;.  If this is true your control is being registered, if it is false your control is being unregistered.  

My sample class is shown below.

uses
  AxCtrls, Registry;

type
  TMyFactory = class(TActiveFormFactory)
  private

  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

implementation

{ TMyActiveFormFactory }

//---------------------------------------------------------
// UdateRegistry
//  This procedure is called anytime you're ActiveX control
//    registered or unregistered.
//  Params: Register;  if True you are being registered
//                     if False you are being unregistered
//---------------------------------------------------------

procedure TMyFactory.UpdateRegistry(Register: Boolean);
var
  oReg: TRegistry;
begin
  inherited;

  oReg := TRegistry.Create;
  try
    if Register then
    begin
      // add extra registration entries here
    end
    else
    begin
      // remove extra registration entries here
    end;
  finally
    oReg.Free;
  end
end;

When that is all done, go to the initialization section of your ActiveX control and change it to the following (the example is for an ActiveForm) and you are done.

initialization
  //TActiveFormFactory.Create(  // old class factory
  TMyFactory.Create(// your new class factory
    ComServer,
    TActiveFormControl,
    TActiveFormX,
    Class_ActiveFormX,
    1,
    '',
    OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
    tmApartment);

Things to remember:

If you need your control&#8217;s ProgID or ClassID that information is already there, passed in with the constructor and saved in FClassID.  To get the ProgID use the function ClassIDToProgID found in ComObj.
Because this code is called during registration debugging is possible but very difficult.   Essentially you have to recompile the VCL to use debug DCU&#8217;s. Even then no guarantees with the UpdateRegistry function.
There are other functions and procedures that you can overwrite here.  Some commonly overwritten procedures include: Create, GetLicenseString, HasMachineLicense, ValidateUserLicense, and occasionally GetProgID.
Just because you put the information into the registry does not necessarily mean you want to take it out.  One case for this behavior is when you want a control to work for a while then stop (so a user is forced to buy the control).
You aren&#8217;t restricted to the registry; many programs are now using XML for loading plugins/addins instead of the Registry.

Touch a file with a specified date/time

Problem/Question/Abstract:

How do I change the date & time of a file specified as a string?

Answer:

Often A file's time is set to represent a version number. For example the datetime may be January 27, 2000 1:03:00AM to represent version 1 patch 3.

This unit presents a procedure which takes two parameters, A file path/name specified as a string and a DateTime.
The specified file's date & time will be changed to match the DateTime specified.

unit Fileutil;

interface
uses System, SysUtils;

{To Change the Date/Time of a file}
procedure TouchFile(FileName: string; Date: TDateTime);

implementation

procedure TouchFile(FileName: string; Date: TDateTime);
var
  TheFile: file;
begin
  AssignFile(TheFile, FileName);
  Reset(TheFile);
  FileSetDate(TFileRec(TheFile).Handle,
    DateTimeToFileDate(Date));
  Close(TheFile);
end;

end.

Enumerating workgroups on your LAN

Problem/Question/Abstract:

Enumerating workgroups on your LAN.

Answer:

{ This code is a copy-paste from a working application.
}

var
  WorkgroupCount: Integer;
  Workgroup: array[1..500] of string[25];

procedure FindAllWorkgroups;
var
  EnumHandle: THandle;
  EntireNetwork: TNetResource;
  Buf: array[1..500] of TNetResource;
  BufSize: Integer; // or DWORD;
  Entries: Integer; // or DWORD;

begin
  FillChar(EntireNetwork, SizeOf(EntireNetwork), 0);
  with EntireNetwork do
  begin
    dwScope := 2;
    dwDisplayType := 6;
    dwUsage := 2;
  end;

  WNetOpenEnum(RESOURCE_GLOBALNET,
    RESOURCETYPE_ANY,
    0,
    @EntireNetwork,
    EnumHandle);

  WorkgroupCount := 0;
  repeat
    Entries := 1;
    BufSize := SizeOf(Buf);

    WNetEnumResource(EnumHandle,
      Entries,
      @Buf,
      BufSize);
    if Entries = 1 then
    begin
      Inc(WorkgroupCount);
      Workgroup[WorkgroupCount] := StrPas(Buf[1].lpRemoteName);
    end;
  until (Entries <> 1);

  WNetCloseEnum(EnumHandle);
end;

Copy a WideString to the clipboard

Problem/Question/Abstract:

I must copy a Unicode string to clipboard. How?

Answer:

Use

Clipboard.SetAsHandle(CF_UNICODETEXT, hUnicodeHandle);

Here's the small code snippet:

{ ... }
mem := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, SelLen);
ptr := GlobalLock(mem);
Move(PWideChar(SelText)^, ptr^, SelLen);
GlobalUnlock(mem);
Clipboard.SetAsHandle(CF_UNICODETEXT, mem);
{ ... }

Getting Rid Of the Annoying SQL Wait Cursor

Problem/Question/Abstract:

How can I Get Rid Of the Annoying SQL Wait Cursor?

Answer:

// Torry's Delphi Tips
// Author Garret Bryl
// Listed 20.02.2003
{
Simply place this one line of code in the OnCreate event of
the form that is showing the annoying SQL Wait cursor...
}

procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crSQLWait] := Screen.Cursors[crHourGlass];
// or whatever cursor you would like to replace the SQL hourglass with
end;

Create a ScanLine implementation of Stretchblt

Problem/Question/Abstract:

How to create a ScanLine implementation of Stretchblt

Answer:

I'm using this routine for animated zooms, so I took special care to keep the stretch centered. In this scenario the simple stretch makes sense and improves performance. For thumbnailing, be aware that when you make a thumbnail from a bmp file from disk, then most of the time is spent on file I/O, the resampling time compared to that is peanuts, same goes for a jpeg, only for those the decoding is what takes long.

unit DeleteScans;

interface

uses
Windows, Graphics;

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
{ScanLine implementation of Stretchblt/Delete_Scans. About twice as fast.
Stretches Src to Dest, rs is source rect, rd is dest. rect. The stretch is centered,
i.e the center of rs is mapped to the center of rd. Src, Dest are assumed to be bottom up}

implementation

uses
Classes, Math;

type
TRGBArray = array[0..64000] of TRGBTriple;
PRGBArray = ^TRGBArray;
TQuadArray = array[0..64000] of TRGBQuad;
PQuadArray = ^TQuadArray;

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
var
xsteps, ysteps: array of Integer;
intscale: Integer;
i, x, y, x1, x2, bitspp, bytespp: Integer;
ts, td: PByte;
bs, bd, WS, hs, w, h: Integer;
Rows, rowd: PByte;
j, c: Integer;
pf: TPixelFormat;
xshift, yshift: Integer;
begin
WS := rs.Right - rs.Left;
hs := rs.Bottom - rs.Top;
w := rd.Right - rd.Left;
h := rd.Bottom - rd.Top;
pf := Src.PixelFormat;
if (pf <> pf32Bit) and (pf <> pf24bit) then
begin
pf := pf24bit;
Src.PixelFormat := pf;
end;
Dest.PixelFormat := pf;
if not (((w <= WS) and (h <= hs)) or ((w >= WS) and (h >= hs))) then
{We do not handle a mix of up-and downscaling, using threadsafe StretchBlt instead}
begin
Src.Canvas.Lock;
Dest.Canvas.Lock;
try
SetStretchBltMode(Dest.Canvas.Handle, STRETCH_DELETESCANS);
StretchBlt(Dest.Canvas.Handle, rd.Left, rd.Top, w, h, Src.Canvas.Handle,
rs.Left, rs.Top, WS, hs, SRCCopy);
finally
Dest.Canvas.Unlock;
Src.Canvas.Unlock;
end;
exit;
end;
if pf = pf24bit then
begin
bitspp := 24;
bytespp := 3;
end
else
begin
bitspp := 32;
bytespp := 4;
end;
bs := (Src.Width * bitspp + 31) and not 31;
bs := bs div 8; {BytesPerScanline Source}
bd := (Dest.Width * bitspp + 31) and not 31;
bd := bd div 8; {BytesPerScanline Dest}
if w < WS then {downsample}
begin
{first make arrays of the skipsteps}
SetLength(xsteps, w);
SetLength(ysteps, h);
intscale := round(WS / w * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to w - 1 do
begin
xsteps[i] := (x2 - x1) * bytespp;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = w - 2 then
c := x1;
end;
xshift := min(max((WS - c) div 2, -rs.Left), Src.Width - rs.Right);
intscale := round(hs / h * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to h - 1 do
begin
ysteps[i] := (x2 - x1) * bs;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = h - 2 then
c := x1;
end;
yshift := min(max((hs - c) div 2, -rs.Top), Src.Height - rs.Bottom);
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
inc(td, bytespp);
inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
inc(td, bytespp);
inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end;
end
else
begin
{first make arrays of the steps of uniform pixels}
SetLength(xsteps, WS);
SetLength(ysteps, hs);
intscale := round(w / WS * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to WS - 1 do
begin
xsteps[i] := x2 - x1;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > w then
x2 := w;
if i = WS - 1 then
c := x1;
end;
if c < w then {>is now not possible}
begin
xshift := (w - c) div 2;
yshift := w - c - xshift;
xsteps[WS - 1] := xsteps[WS - 1] + xshift;
xsteps[0] := xsteps[0] + yshift;
end;
intscale := round(h / hs * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to hs - 1 do
begin
ysteps[i] := (x2 - x1);
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > h then
x2 := h;
if i = hs - 1 then
c := x1;
end;
if c < h then
begin
yshift := (h - c) div 2;
ysteps[hs - 1] := ysteps[hs - 1] + yshift;
yshift := h - c - yshift;
ysteps[0] := ysteps[0] + yshift;
end;
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
inc(td, bytespp);
end;
inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
inc(td, bytespp);
end;
inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end;
end;
end;

end.

Render a TRichEdit text onto a canvas

Problem/Question/Abstract:

How to render a TRichEdit text onto a canvas?

Answer:

procedure RichEditToCanvas(RichEdit: TRichEdit; Canvas: TCanvas; PixelsPerInch:
Integer);
var
ImageCanvas: TCanvas;
fmt: TFormatRange;
begin
ImageCanvas := Canvas;
with fmt do
begin
hdc := ImageCanvas.Handle;
hdcTarget := hdc;
// rect needs to be specified in twips (1/1440 inch) as unit
rc := Rect(0, 0,
ImageCanvas.ClipRect.Right * 1440 div PixelsPerInch,
ImageCanvas.ClipRect.Bottom * 1440 div PixelsPerInch
);
rcPage := rc;
chrg.cpMin := 0;
chrg.cpMax := RichEdit.GetTextLen;
end;
SetBkMode(ImageCanvas.Handle, TRANSPARENT);
RichEdit.Perform(EM_FORMATRANGE, 1, Integer(@fmt));
// next call frees some cached data
RichEdit.Perform(EM_FORMATRANGE, 0, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RichEditToCanvas(RichEdit1, Image1.Canvas, Self.PixelsPerInch);
Image1.Refresh;
end;

Working with multiselect grids

Problem/Question/Abstract:

Working with multiselect grids

Answer:

Delphi 2.0 multiselect grids have an undocumented SelectedRows property, a TBookmark list.
You can use it with code like this:


with DbGrid1 do
begin
��for i := 0 to SelectedRows.Count-1 do
  begin
����DataSource.DataSet.Bookmark := SelectedRows[i];
����{ the dataset is positioned on the selection. do your stuff }
��end;
end;

Use the OnDraw methods of a TListView in vsReport view style

Problem/Question/Abstract:

Does anyone know how to use the OnDraw methods in the TListView - vsReport? I want to draw both the list item and the list item's sub-items, but it seems to me that the OnDraw only gets called on the item. I have tried all the draw methods but cannot realy figure out how to draw in the subitems rect.

Answer:

You are right, it gets called by the TListItem but since you have the TListItem, you can draw the subitems as well. Example DrawItem:

{ ... }
if Item.Index = 0 then
  Sender.Canvas.Brush.Color := clRed
else
  Sender.Canvas.Brush.Color := clYellow;
Sender.Canvas.FillRect(Rect);
for x := 0 to TListView(Sender).Columns.Count - 1 do
  if x = 0 then
    Sender.Canvas.TextOut(Rect.Left + 2, Rect.Top, Item.Caption)
  else
    Sender.Canvas.TextOut((Rect.Left + 2) + Sender.Column[x].Width,
      Rect.Top, Item.SubItems.Strings[x - 1]);
{ ... }

How to add items to a TComboBox upon an [ENTER] key press

Problem/Question/Abstract:

I would like my user to be able to enter items into a combobox and add each item upon pressing the enter key. Is there a simple way to do this. I started using csdropdown style. Then I tried using the keydown event with key 13, so that when the user presses enter, the user's entry is added to combobox.items, but so far its not working. I'll keep hacking away at it, but I thought perhaps there is an existing solution to this problem, either starting from a different control, or using a different method in TComboBox.

Answer:

This works for me on a csDropDown combobox (D5.01):

procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char);
begin
  if key = #13 then
  begin
    if combobox1.text <> emptystr then
      combobox1.items.add(combobox1.text);
    key := #0;
  end;
end;

How to drop a TComboBox up instead of down

Problem/Question/Abstract:

You know how when you open a TComboBox that is near the bottom of the physical screen, Windows places the list above the ComboBox rather than below. Is there any way in Delphi to force that behavior? In other words, I'm trying to come up with a drop-up TComboBox.

Answer:

Here is some code that may help you:

{ ... }
cbxMaxWidth: integer;

procedure pmAdjustDropList(var Msg: TMessage); message WM_USER + 1800;
{ ... }

  procedure TForm1.pmAdjustDropList(var Msg: TMessage); {WM_USER + 1800;}
  var
    LHnd: HWnd;
    rct: TRect;
    pt: TPoint;
    x: integer;
  begin
    x := ComboBox1.Height + 1;
    ComboBox1.Perform(CB_GETDROPPEDCONTROLRECT, 0, longint(@rct));
    pt := Point(rct.Left + 1, rct.Top + x);
    {Gets the handle of the window containing the pt}
    LHnd := WindowFromPoint(pt);
    rct.Left := rct.Right - cbxMaxWidth; {cbxMaxWidth is maximum width for box}
    if rct.Right - rct.Left > ComboBox1.Width then
    begin
      {Up with right side of combobox}
      pt := ComboBox1.ScreenToClient(rct.BottomRight);
      OffsetRect(rct, ComboBox1.Width - (pt.x), x);
      MoveWindow(LHnd, rct.Left, rct.Top, rct.Right - rct.Left, rct.Bottom - rct.Top, true);
    end;
  end;

  procedure TForm1.ComboBox1DropDown(Sender: TObject);
  begin
    PostMessage(Handle, WM_USER + 1800, 0, 0);
  end;

How to read the disk ID number

Problem/Question/Abstract:

How do I read system information? In my case I want to read a clients hard disk ID number.

Answer:

Use GetVolumeInformation, yet gets the formatted serial number, not the manufacturers HD number.


procedure TForm1.Button1Click(Sender: TObject);
var
  VolumeName, FileSystemName: array[0..MAX_PATH - 1] of Char;
  VolumeSerialNo: DWord;
  MaxComponentLength, FileSystemFlags: Integer;
begin
  GetVolumeInformation('C:\', VolumeName, MAX_PATH, @VolumeSerialNo, MaxComponentLength, FileSystemFlags, FileSystemName, MAX_PATH);
  Memo1.Lines.Add('VName = ' + VolumeName);
  Memo1.Lines.Add('SerialNo = $ ' + IntToHex(VolumeSerialNo, 8));
  Memo1.Lines.Add('CompLen = ' + IntToStr(MaxComponentLength));
  Memo1.Lines.Add('Flags = $' + IntToHex(FileSystemFlags, 4));
  Memo1.Lines.Add('FSName = ' + FileSystemName);
end;

Save and load the state of a TMenuItem to/ from a TIniFile

Problem/Question/Abstract:

How to save and load the state of a TMenuItem to/ from a TIniFile

Answer:

uses
  IniFiles;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  ini: TIniFile;
begin
  {Save the checked state of each menu item when the form closes}
  Ini := TIniFile.Create('mysettings.ini');
  Ini.WriteBool('Settings', 'MenuItem1Checked', MenuItem1.Checked);
  Ini.WriteBool('Settings', 'MenuItem2Checked', MenuItem2.Checked);
  Ini.WriteBool('Settings', 'MenuItem2Checked', MenuItem2.Checked);
  Ini.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  ini: TIniFile;
begin
  {Reload the checked state of each menu item when the form opens}
  Ini := TIniFile.Create('mysettings.ini');
  MenuItem1.Checked := Ini.ReadBool('Settings', 'MenuItem1Checked', False);
  MenuItem2.Checked := Ini.ReadBool('Settings', 'MenuItem2Checked', False);
  MenuItem3.Checked := Ini.ReadBool('Settings', 'MenuItem3Checked', False);
  Ini.Free;
end;

Find the parent TTabSheet of a control

Problem/Question/Abstract:

I am trying to write a recursive function that will go through all the parents of a component until it finds the tabsheet that it is on (ie: TEdit -> TGroupBox -> TTabSheet). Then I would like to get the caption of that tabsheet.

Answer:

Solve 1:

If you walk the tree up - from root - you need recursion, but the opposite way is linear as each element (control) has only one immediate parent, so recursion would be nonsense. A code like this should do:

function GetParentTabsheet(C: TControl): TTabsheet;
begin
  Result := TTabSheet(C.Parent);
  while (Result <> nil) and not Result.InheritsFrom(TTabSheet) do
    Result := TTabSheet(Result.Parent);
end;

If you really want it recursive:

function GetParentTabsheet(C: TControl): TTabsheet;
begin
  Result := TTabSheet(C.Parent);
  if (Result <> nil) and not Result.InheritsFrom(TTabSheet) then
    Result := GetParentTabsheet(Result);
end;


Solve 2:

function GetParentTabSheet(Control: TControl): TTabSheet;
begin
  while Assigned(Control) and not (Control is TTabSheet) do
    Control := Control.Parent;
  Result := TTabSheet(Control);
end;


Solve 3:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(TTabSheet(TGroupBox(Edit1.Parent).Parent).Caption);
end;

How to enter dates into a TDateTimePicker by keyboard only

Problem/Question/Abstract:

We have decided to replace all occurrences of TMaskEdit in our applications with TDateTimePicker's (of course only where they were used for entering dates). The problem is making the transition as easy as possible for the users. TDateTimePicker as it is is not very well-suited for keyboard-only input. The first annoyance is that you have to explicitly enter the separators. TMaskEdit just jumped to the next figure if you entered a number instead of the separator character. It becomes worse still when ShowCheckbox is True. In that case the focus is automatically shifted to the checkbox after having entered the first two digits, essentially making it impossible to enter a date by keyboard only (unless you manually cursor to the every single figure). Does anyone know if it possible at all to overcome these limitations by simply subclassing TDateTimePicker?

Answer:

Here is the routine that I use for date entry edits. Feel free to use it if you just want keyboard entry of dates. Here's the way it works: As the user types in the edit, it's checked against the current ShortDateFormat setting to determine whether it's in the month, day or year portion. If, for instance, they are in the month portion and they type a '3', it knows that it must be the third month and so puts '03' and goes to the next section (if any). If you want to default any portion to the current day, month or year, simply hit the space bar. This gives users a really fast way to fill in dates, especially the current day's. All you need to do is assign the OnKeyPress event of any edit control and make a simple call:

DateKeyPress(self, Key);

{Included because I use it to tab to the next control when the date is complete}

procedure PressTabKey(Shift: boolean = false);
begin
  if Shift then
    keybd_event(VK_SHIFT, 0, 0, 0);
  keybd_event(VK_TAB, 0, 0, 0);
  keybd_event(VK_TAB, 0, KEYEVENTF_KEYUP, 0);
  if Shift then
    keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);
end;

procedure DateKeyPress(Sender: TObject; var Key: char);
const
  Zero: char = '0';
  DateParts: array[1..3] of string = ('', '', '');
  SeparatorChar: string = '';

  procedure GetDateParts;
  var
    x, y: integer;
    s: string;
    c: char;
  begin
    s := ShortDateFormat;
    y := 1;
    c := s[1];
    for x := 1 to length(s) do
      if (s[x] <> DateSeparator) then
      begin
        if (s[x] <> c) then
        begin
          c := s[x];
          inc(y);
        end;
        DateParts[y] := DateParts[y] + s[x];
      end
      else
      begin
        inc(y);
        c := s[x + 1];
      end;
    if pos(DateSeparator, s) <> 0 then
      SeparatorChar := DateSeparator
    else
      SeparatorChar := '';
  end;

  function FixDatePart(s: string; Part: integer): string;
  begin
    if (s <> '') and (s[length(s)] = DateSeparator) then
      delete(s, length(s), 1);
    if (s = '') then
      s := FormatDateTime(DateParts[Part], Now);
    if (DateParts[Part][1] in ['m', 'M', 'd', 'D']) then
      result := format('%.' + IntToStr(length(DateParts[Part])) + 'd', [StrToInt(s)])
    else if (length(s) < length(DateParts[Part])) then
      result := copy(FormatDateTime(DateParts[Part], Now), 1,
        length(Dateparts[Part]) - length(s)) + s
    else
      result := s;
  end;

var
  s: string;
  x,
    sepLength: integer;
begin
  if DateParts[1] = '' then
    GetDateParts;
  if ord(Key) in ActionKeys then
    exit;
  s := copy(TEdit(Sender).Text, 1, TEdit(Sender).SelStart);
  x := length(s);
  sepLength := length(SeparatorChar);
  case Key of
    ' ':
      begin
        if (x = length(DateParts[1]) + sepLength) then
          s := s + FixDatePart('', 2) + SeparatorChar
        else if (x = length(DateParts[1] + DateParts[2]) + (sepLength * 2)) then
          s := s + FixDatePart('', 3)
        else if (x = 0) then
          s := FixDatePart('', 1) + SeparatorChar
        else if (x <= length(DateParts[1])) then
          s := FixDatePart(s, 1) + SeparatorChar + FixDatePart('', 2) + SeparatorChar
        else if (x <= (length(DateParts[1] + DateParts[2]) + (sepLength * 2))) then
          s := copy(s, 1, length(DateParts[1]) + sepLength) + FixDatePart(copy(s, length(DateParts[1]) + sepLength + 1, length(s)), 2) + SeparatorChar + FormatDateTime(DateParts[3], Now)
        else
          s := copy(s, 1, length(DateParts[1] + DateParts[2]) + (sepLength * 2)) +
            FixDatePart(copy(s, length(DateParts[1] + DateParts[2]) +
            (sepLength * 2) + 1, length(s)), 3);
        TEdit(Sender).Text := s;
        Key := #0;
        TEdit(Sender).SelStart := length(s);
      end;
    '0'..'9':
      begin
        if (x in [length(DateParts[1]), length(DateParts[1] + DateParts[2]) + sepLength]) then
          s := s + SeparatorChar + Key
        else if (x = 0) and (((DateParts[1][1] in ['m', 'M']) and (Key in ['2'..'9'])) or((DateParts[1][1] in ['d', 'D']) and (Key in ['4'..'9']))) then
          s := FixDatePart(Key, 1) + SeparatorChar
        else if (x = length(DateParts[1]) + sepLength) and (((DateParts[2][1] in ['m', 'M']) and (Key in ['2'..'9'])) or ((DateParts[2][1] in ['d', 'D']) and (Key in ['4'..'9']))) then
          s := s + FixDatePart(Key, 2) + SeparatorChar
        else
          s := s + Key;
        if (length(s) = length(DateParts[1])) or (length(s) = length(DateParts[1] + DateParts[2]) + sepLength) then
          s := s + SeparatorChar;
        TEdit(Sender).Text := s;
        Key := #0;
        TEdit(Sender).SelStart := length(s);
      end;
    { uncomment this to use N/A values
    'n','N':
      begin
        TEdit(Sender).Text := 'N/A';
        TEdit(Sender).SelStart := 0;
        TEdit(Sender).SelLength := 3;
        Key := #0;
      end;}
  else
    begin
      if (Key = DateSeparator) then
      begin
        if s[x] <> DateSeparator then
        begin
          if x = length(DateParts[1]) - 1 then
            s := Zero + s + DateSeparator
          else if x = 4 then
          begin
            insert(Zero, s, 4);
            s := s + '/';
          end;
        end;
        TEdit(Sender).Text := s;
        Key := #0;
        TEdit(Sender).SelStart := length(s);
      end
      else
        Key := #0;
    end;
  end;
  if length(TEdit(Sender).Text) = length(ShortDateFormat) then
    PressTabKey;
end;

Convert your boolean values to the meaningful words

Problem/Question/Abstract:

How I convert boolean values to the words depending on the situation? For example, TRUE here means "Enabled", and FALSE there means "Failed"?

Answer:

Solve 1:

Here is the code snippet to do the job. If the second parameter is omitted, the function returns "TRUE" or "FALSE".
Modify the function declaration to change the default returning values. Expand TBooleanWordType and BooleanWord definitions to include more specific values if needed.

interface
{...}
type
  TBooleanWordType =
    (bwTrue, bwYes, bwOn, bwEnabled, bwSuccessful, bwOK, bwOne);
  {...}
function BoolToStr(AValue: boolean;
  ABooleanWordType: TBooleanWordType = bwTrue): string;
{...}
  {=====================================================}
implementation
{...}
const
  BooleanWord: array[boolean, TBooleanWordType] of string =
  (
    ('FALSE', 'No', 'Off', 'Disabled', 'Failed', 'Cancel', '0'),
    ('TRUE', 'Yes', 'On', 'Enabled', 'Successful', 'OK', '1')
    );

  {...}
    {-----------------------------------------------------}

function BoolToStr(AValue: boolean;
  ABooleanWordType: TBooleanWordType = bwTrue): string;
begin
  Result := BooleanWord[AValue, ABooleanWordType];
end; {--BoolToStr--}
{...}


Solve 2:

interface

function BoolToStr(b: boolean; TrueValue: string = '1'; FalseValue: string = '0'):
  string; overload;

implementation

function BoolToStr(b: boolean; TrueValue: string = '1'; FalseValue: string = '0'):
  string; overload;
begin
  if b then
    Result := TrueValue
  else
    Result := FalseValue,
end;

// example for italian language
s := BoolToStr(CheckBox1.Checked, 'Si', 'No');

Add this overloaded Function to the unit.


Solve 3:

const
  arrBooleanValues: array[Boolean] of ShortString = ('False', 'True');
var
  b: Boolean;
  s: string;
begin
  b := False;
  s := arrBooleanValues[b]; // 'False'
  b := True;
  s := arrBooleanValues[b]; // 'True'
end;

Read and write icon files

Problem/Question/Abstract:

How to read and write icon files

Answer:

{ icon. pas}

unit Icons;

interface

uses
  windows, sysutils;

type
  PByte = ^Byte;
  PBitmapInfo = ^BitmapInfo;

  {These first two structs represent how the icon information is stored when it is
  bound into a EXE or DLL file. Structure members are WORD aligned and the last
  member of the structure is the ID instead of the imageoffset.}

type
  PMEMICONDIRENTRY = ^TMEMICONDIRENTRY;
  TMEMICONDIRENTRY = packed record
    bWidth: Byte; {Width of the image}
    bHeight: Byte; {Height of the image (times 2) }
    bColorCount: Byte; {Number of colors in image (0 if >=8bpp) }
    bReserved: Byte; {Reserved}
    wPlanes: WORD; {Color Planes}
    wBitCount: WORD; {Bits per pixel}
    dwBytesInRes: DWORD; {How many bytes in this resource?}
    nID: WORD; {The ID}
  end;

type
  PMEMICONDIR = ^TMEMICONDIR;
  TMEMICONDIR = packed record
    idReserved: WORD; {Reserved}
    idType: WORD; {Resource type (1 for icons) }
    idCount: WORD; {How many images?}
    idEntries: array[0..10] of TMEMICONDIRENTRY; {The entries for each image}
  end;

  {These next two structs represent how the icon information is stored in an ICO file.}

type
  PICONDIRENTRY = ^TICONDIRENTRY;
  TICONDIRENTRY = packed record
    bWidth: Byte; {Width of the image}
    bHeight: Byte; {Height of the image (times 2) }
    bColorCount: Byte; {Number of colors in image (0 if >=8bpp) }
    bReserved: Byte; {Reserved}
    wPlanes: WORD; {Color Planes}
    wBitCount: WORD; {Bits per pixel}
    dwBytesInRes: DWORD; {How many bytes in this resource?}
    dwImageOffset: DWORD; {Where in the file is this image}
  end;

type
  PICONDIR = ^TICONDIR;
  TICONDIR = packed record
    idReserved: WORD; {Reserved}
    idType: WORD; {Resource type (1 for icons) }
    idCount: WORD; {How many images?}
    idEntries: array[0..0] of TICONDIRENTRY; {The entries for each image}
  end;

  {The following two structs are for the use of this program in manipulating icons.
  They are more closely tied to the operation of this program than the structures
  listed above. One of the main differences is that they provide a pointer to the
  DIB information of the masks.}

type
  PICONIMAGE = ^TICONIMAGE;
  TICONIMAGE = packed record
    Width, Height, Colors: UINT; {Width, Height and bpp}
    lpBits: Pointer; {ptr to DIB bits}
    dwNumBytes: DWORD; {How many bytes?}
    pBmpInfo: PBitmapInfo;
  end;

  {
    TICONIMAGE = packed record
      Width, Height, Colors: UINT;  {Width, Height and bpp}
  lpBits: pointer; {ptr to DIB bits}
  dwNumBytes: DWORD; {How many bytes?}
  lpbi: PBITMAPINFO; {ptr to header}
  lpXOR: LPBYTE; {ptr to XOR image bits}
  lpAND: LPBYTE; {ptr to AND image bits}
end;
}

type
  PICONRESOURCE = ^TICONRESOURCE;
  TICONRESOURCE = packed record
    nNumImages: UINT; {How many images?}
    IconImages: array[0..10] of TICONIMAGE; {Image entries}
  end;

  {
    TICONRESOURCE = packed record
      bHasChanged: BOOL;  {Has image changed?}
  szOriginalICOFileName: array[0..MAX_PATH] of Char; {Original name}
  szOriginalDLLFileName: array[0..MAX_PATH] of Char; {Original name}
  nNumImages: UINT; {How many images?}
  IconImages: array[0..0] of ICONIMAGE; {Image entries}
end;
}

type
  TPageInfo = packed record
    Width: Byte;
    Height: Byte;
    ColorQuantity: Integer;
    Reserved: DWORD;
    PageSize: DWORD;
    PageOffSet: DWORD;
  end;

type
  TPageDataHeader = packed record
    PageHeadSize: DWORD;
    XSize: DWORD;
    YSize: DWORD;
    SpeDataPerPixSize: Integer;
    ColorDataPerPixSize: Integer;
    Reserved: DWORD;
    DataAreaSize: DWORD;
    ReservedArray: array[0..15] of Char;
  end;

type
  TIcoFileHeader = packed record
    FileFlag: array[0..3] of Byte;
    PageQuartity: Integer;
    PageInfo: TPageInfo;
  end;

  {function WriteIconToFile(Bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean; overload;}
function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex:
  string): Boolean;
function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;

implementation

function WriteICOHeader(hFile: HWND; nNumEntries: UINT): Boolean;
type
  TFIcoHeader = record
    wReserved: WORD;
    wType: WORD;
    wNumEntries: WORD;
  end;
var
  IcoHeader: TFIcoHeader;
  {Output: WORD;}
  dwBytesWritten: DWORD;
begin
  Result := False;
  IcoHeader.wReserved := 0;
  IcoHeader.wType := 1;
  IcoHeader.wNumEntries := WORD(nNumEntries);
  if not WriteFile(hFile, IcoHeader, SizeOf(IcoHeader), dwBytesWritten, nil) then
  begin
    MessageBox(0, pchar(SysErrorMessage(GetLastError)), 'info', MB_OK);
    exit;
  end;
  if dwBytesWritten <> SizeOf(IcoHeader) then
    exit;
  {
  Output := 0;
  {Write 'reserved' WORD}
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  {Did we write a WORD?}
  if dwBytesWritten <> SizeOf(WORD) then
    exit;
  {Write 'type' WORD (1) }
  Output := 1;
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  if dwBytesWritten <> SizeOf(WORD) then
    exit;
  {Write Number of Entries}
  Output := WORD(nNumEntries);
  if not WriteFile(hFile, Output, SizeOf(WORD), dwBytesWritten, nil) then
    exit;
  if dwBytesWritten <> SizeOf(WORD) then
    exit;
  }
    Result := True;
end;

function CalculateImageOffset(lpIR: PICONRESOURCE; nIndex: UINT): DWORD;
var
  dwSize: DWORD;
  i: Integer;
begin
  {Calculate the ICO header size}
  dwSize := 3 * sizeof(WORD);
  {Add the ICONDIRENTRY's}
  inc(dwSize, lpIR.nNumImages * sizeof(TICONDIRENTRY));
  {Add the sizes of the previous images}
  for i := 0 to nIndex - 1 do
    inc(dwSize, lpIR.IconImages[i].dwNumBytes);
  {We're there - return the number}
  Result := dwSize;
end;

function WriteIconResourceToFile(hFile: hwnd; lpIR: PICONRESOURCE): Boolean;
var
  i: UINT;
  dwBytesWritten: DWORD;
  ide: TICONDIRENTRY;
  dwTemp: DWORD;
begin
  {Open the file}
  Result := False;
  {Write the ICONDIRENTRY's}
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    {Convert internal format to ICONDIRENTRY}
    ide.bWidth := lpIR^.IconImages[i].Width;
    ide.bHeight := lpIR^.IconImages[i].Height;
    ide.bReserved := 0;
    ide.wPlanes := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biPlanes;
    ide.wBitCount := lpIR^.IconImages[i].pBmpInfo.bmiHeader.biBitCount;
    if ide.wPlanes * ide.wBitCount >= 8 then
      ide.bColorCount := 0
    else
      ide.bColorCount := 1 shl (ide.wPlanes * ide.wBitCount);
    ide.dwBytesInRes := lpIR^.IconImages[i].dwNumBytes;
    ide.dwImageOffset := CalculateImageOffset(lpIR, i);
    {Write the ICONDIRENTRY out to disk}
    if not WriteFile(hFile, ide, sizeof(TICONDIRENTRY), dwBytesWritten, nil) then
      exit;
    {Did we write a full ICONDIRENTRY ?}
    if dwBytesWritten <> sizeof(TICONDIRENTRY) then
      exit;
  end;
  {Write the image bits for each image}
  for i := 0 to lpIR^.nNumImages - 1 do
  begin
    dwTemp := lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage;
    {Set the sizeimage member to zero}
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := 0;
    {Write the image bits to file}
    if not WriteFile(hFile, lpIR^.IconImages[i].lpBits^,
      lpIR^.IconImages[i].dwNumBytes,
      dwBytesWritten, nil) then
      exit;
    if dwBytesWritten <> lpIR^.IconImages[i].dwNumBytes then
      exit;
    {Set it back}
    lpIR^.IconImages[i].pBmpInfo^.bmiHeader.biSizeImage := dwTemp;
  end;
  Result := True;
end;

function AWriteIconToFile(bitmap: hBitmap; Icon: hIcon; szFileName: string): Boolean;
var
  fh: file of Byte;
  IconInfo: _ICONINFO;
  PageInfo: TPageInfo;
  PageDataHeader: TPageDataHeader;
  IcoFileHeader: TIcoFileHeader;
  BitsInfo: tagBITMAPINFO;
  p: Pointer;
  PageDataSize: Integer;
begin
  Result := False;
  GetIconInfo(Icon, IconInfo);
  AssignFile(fh, szFileName);
  FileMode := 1;
  Reset(fh);
  GetDIBits(0, Icon, 0, 32, nil, BitsInfo, DIB_PAL_COLORS);
  GetDIBits(0, Icon, 0, 32, p, BitsInfo, DIB_PAL_COLORS);
  PageDataSize := SizeOf(PageDataHeader) + BitsInfo.bmiHeader.biBitCount;
  PageInfo.Width := 32;
  PageInfo.Height := 32;
  PageInfo.ColorQuantity := 65535;
  Pageinfo.Reserved := 0;
  PageInfo.PageSize := PageDataSize;
  PageInfo.PageOffSet := SizeOf(IcoFileHeader);
  IcoFileHeader.FileFlag[0] := 0;
  IcoFileHeader.FileFlag[1] := 0;
  IcoFileHeader.FileFlag[2] := 1;
  IcoFileHeader.FileFlag[3] := 0;
  IcoFileHeader.PageQuartity := 1;
  IcoFileHeader.PageInfo := PageInfo;
  FillChar(PageDataHeader, SizeOf(PageDataHeader), 0);
  PageDataHeader.XSize := 32;
  PageDataHeader.YSize := 32;
  PageDataHeader.SpeDataPerPixSize := 0;
  PageDataHeader.ColorDataPerPixSize := 32;
  PageDataHeader.PageHeadSize := SizeOf(PageDataHeader);
  PageDataHeader.Reserved := 0;
  PageDataHeader.DataAreaSize := BitsInfo.bmiHeader.biBitCount;
  BlockWrite(fh, IcoFileHeader, SizeOf(IcoFileHeader));
  BlockWrite(fh, PageDataHeader, SizeOf(PageDataHeader));
  BlockWrite(fh, p, BitsInfo.bmiHeader.biBitCount);
  CloseFile(fh);
end;

function AdjustIconImagePointers(lpImage: PICONIMAGE): Bool;
begin
  if lpImage = nil then
  begin
    Result := False;
    exit;
  end;
  lpImage.pBmpInfo := PBitMapInfo(lpImage^.lpBits);
  lpImage.Width := lpImage^.pBmpInfo^.bmiHeader.biWidth;
  lpImage.Height := (lpImage^.pBmpInfo^.bmiHeader.biHeight) div 2;
  lpImage.Colors := lpImage^.pBmpInfo^.bmiHeader.biPlanes *
    lpImage^.pBmpInfo^.bmiHeader.biBitCount;
  Result := true;
end;

function ExtractIconFromFile(ResFileName: string; IcoFileName: string; nIndex:
  string): Boolean;
var
  h: HMODULE;
  lpMemIcon: PMEMICONDIR;
  lpIR: TICONRESOURCE;
  src: HRSRC;
  Global: HGLOBAL;
  i: Integer;
  hFile: HWND;
begin
  Result := False;
  hFile := CreateFile(pchar(IcoFileName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS,
    FILE_ATTRIBUTE_NORMAL, 0);
  if hFile = INVALID_HANDLE_VALUE then
    exit; {Error Create File}
  h := LoadLibraryEx(pchar(ResFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
  if h = 0 then
    exit;
  try
    src := FindResource(h, pchar(nIndex), RT_GROUP_ICON);
    if src = 0 then
      Src := FindResource(h, Pointer(StrToInt(nIndex)), RT_GROUP_ICON);
    if src <> 0 then
    begin
      Global := LoadResource(h, src);
      if Global <> 0 then
      begin
        lpMemIcon := LockResource(Global);
        if Global <> 0 then
        begin
          {lpIR := @IR;}
          try
            lpIR.nNumImages := lpMemIcon.idCount;
            {Write the header}
            for i := 0 to lpMemIcon^.idCount - 1 do
            begin
              src := FindResource(h, MakeIntResource(lpMemIcon^.idEntries[i].nID),
                RT_ICON);
              if src <> 0 then
              begin
                Global := LoadResource(h, src);
                if Global <> 0 then
                begin
                  lpIR.IconImages[i].dwNumBytes := SizeofResource(h, src);
                  GetMem(lpIR.IconImages[i].lpBits, lpIR.IconImages[i].dwNumBytes);
                  CopyMemory(lpIR.IconImages[i].lpBits, LockResource(Global),
                    lpIR.IconImages[i].dwNumBytes);
                  if not AdjustIconImagePointers(@(lpIR.IconImages[i])) then
                    exit;
                end;
              end;
            end;
            if WriteICOHeader(hFile, lpIR.nNumImages) then {No Error Write File}
              if WriteIconResourceToFile(hFile, @lpIR) then
                Result := True;
          finally
            for i := 0 to lpIR.nNumImages - 1 do
              if assigned(lpIR.IconImages[i].lpBits) then
                FreeMem(lpIR.IconImages[i].lpBits);
          end;
        end;
      end;
    end;
  finally
    FreeLibrary(h);
  end;
  CloseHandle(hFile);
end;

end.

Detect whether your program runs in the IDE

Problem/Question/Abstract:

Detect whether your program runs in the IDE

Answer:

Below is another way to detect whether your program runs in the Delphi IDE


program p;
begin
  if DebugHook <> 0 then
    ShowMessage('Running in Delphi IDE');
end.

How can I tell the system to rename a file on the next reboot?

Problem/Question/Abstract:

How can I tell the system to rename a file on the next reboot?

Answer:

Windows has a mechanism to replace files that are currently in use on next boot. So what the program could do is

save the updated version under another name, preferably in the applications directory (source and target need to be on the same volume).

the execute the following code:

if Win32Platform = VER_PLATFORM_WIN32_NT then
  MoveFileEx(Pchar(tempFilenameWithPath),
    Pchar(realfilenamewithpath),
    MOVEFILE_REPLACE_EXISTING or MOVEFILE_DELAY_UNTIL_REBOOT)
else
  WritePrivateProfileString(
    'rename',
    Pchar(realfilenamewithpath),
    Pchar(tempFilenameWithPath),
    'wininit.ini');

Note that the wininit.ini file needs to be set up using the short (DOS 8.3) versions of long path and filenames.