How can I show the source of a HTML-site in a TMemo?

Problem/Question/Abstract:

How can I show the source of a HTML-site in a TMemo?

Answer:

// You need a TMemo, a TButton und a NMHTTP

procedure TForm1.Button1Click(Sender: TObject);
begin
  NMHTTP1.Get('www.dev4u.ch');
  memo1.Text := NMHTTP1.Body
end;

Web Page to Image File

Problem/Question/Abstract:

It was asked how one might save a webpage to disk as a image file from IE. I did not see an obvious way to do with with IE below is a way to get the URL from IE and then open it with PBear's THTMLViewer and save it as a image file.

Answer:

This is written in Delphi 5 but with a little modification, most if not all of it could be used in Delphi 3 or higher, Kylix and maybe C++Builder.

First of all, you need Dave Baldwin's PBear THTMLView or THTMLLite.  It is available here:

http://www.pbear.com/htmlviewers.html

Get the Indy demo application since it supports actually downloading web pages and images from the web via http.

Open up the Demo application and add two buttons to the tool bar.  The caption on the first is "DDE URL" and the second is "As Image".  For the click event of the "DDE URL" button should look like this:

procedure THTTPForm.btnDDEURLClick(Sender: TObject);
begin
  UrlComboBox.Text := GetDDEUrl; // get the URL
  GetButtonClick(nil); // Navigate to the URL
end;

GetDDEUrl calls the following function which you will need to above the method:

// using DDE gets the URL from the active browser

function GetDDEUrl: string;
  function GetUrl(sService: string): string;
  var
    Dde: TDdeClientConv;
  begin
    Dde := TDdeClientConv.Create(nil);
    try
      Dde.ConnectMode := ddeManual;
      Dde.SetLink(sService, 'WWW_GetWindowInfo');
      if Dde.OpenLink then
      try
        Result := string(Dde.RequestData('0xFFFFFFFF'));
        if Length(Result) > 0 then
        begin // trim up the results
          Delete(Result, 1, 1);
          Delete(Result, Pos('",', Result), Length(Result));
        end;
      finally
        Dde.CloseLink;
      end;
    finally
      dde.Free;
    end;
  end;
begin
  // try a few browsers until we get one
  Result := GetUrl('Netscape');
  if Result = '' then
    Result := GetUrl('IExplore');
  if Result = '' then
    Result := GetUrl('Opera');
  if Result = '' then
    Result := GetUrl('Mosaic');
end;

The click event of the As Image button should look like this:

procedure THTTPForm.btnSaveImageClick(Sender: TObject);
var
  img: TBitmap;
{$IFDEF GIF}
  gif: TGifImage;
{$ENDIF}
  Jpg: TJPEGImage;
  ext: string;
begin
  if SavePictureDialog.Execute then
  begin
    Img := TBitmap.Create;
    try
      img.Height := FrameBrowser.ClientHeight;
      img.Width := FrameBrowser.ClientWidth;
      img.Canvas.Brush := FrameBrowser.Brush;
      img.Canvas.FillRect(FrameBrowser.ClientRect);
      img.Canvas.Lock;
      FrameBrowser.PaintTo(img.Canvas.Handle, 0, 0);
      img.Canvas.Unlock;
      ext := UpperCase(ExtractFileExt(SavePictureDialog.FileName));
      if SameText(ext, '.JPEG') or SameText(ext, '.JPG') then
      begin
        Jpg := TJPEGImage.Create;
        try
          Jpg.CompressionQuality := 100;
          Jpg.Assign(img);
          Jpg.SaveToFile(SavePictureDialog.FileName);
        finally
          Jpg.Free;
        end;
      end
      else
{$IFDEF GIF}if SameText(ext, '.GIF') then
        begin
          gif := TGIFImage.Create;
          try
            gif.Assign(img);
            gif.SaveToFile(SavePictureDialog.FileName);
          finally
            gif.Free;
          end;
        end
        else
{$ENDIF}
          img.SaveToFile(SavePictureDialog.FileName);
    finally
      img.free;
    end;
  end;
end;

You will need to add "Jpeg, DDEMan, RXGif" to the uses clause of the unit you are in.  If you don't have RXLib ( http://einstein.fet.uni-hannover.de/~od/rxlib/ ) then you will need to use some other GIF library.  If you don't have a Gif library then add the line {$UNDEF GIF} at the top of the unit.  If you do have a gif library then add the line {$DEFINE GIF} at the top of the unit.

You will also need to add a TSavePictureDialog named SavePictureDialog.  Set the DefaultExt property to .JPEG or .BMP.  You may also want to clean up the filter to only show supported image formats.

Now run your program.  Click the "DDE URL" button and it will navigate to the page currently open in your active browser.  Then resize the page for maximum efficency and click "As Image" then name the image and save it.  You could modify this to have no user interaction if you like.

How to use a TTreeView to list all available reports in a program

Problem/Question/Abstract:

I am trying to use the TTreeView to list all the available reports in my application. I would like to click on a specific treenode and then click an button to print a specific report. I don't know what property to use or how can I go about getting the results.

Answer:

Solve 1:

There are a few ways to do this. The way I usually do this is to allocate memory for the report name and then add this as a pointer to the node. You can then dereference the pointer to get the info back. Here's an example of attaching information from a database.

if wwTable5.RecordCount > 0 then
begin
  TreeNode := Items.AddChildObject(CurrentPatient, 'Treatments', nil);
  TreeNode.ImageIndex := 5;
  TreeNode.SelectedIndex := 5;
  wwTable5.First;
  while not wwTable5.EOF do
  begin
    New(NodeRecord);
    NodeRecord^.RecType := Treatment;
    NodeRecord^.RecInfo := wwTable5Number.AsInteger;
    Items.AddChildObject(TeeNode, 'Course: ' + wwTable5CourseNumber.AsString,
      NodeRecord);
    wwTable5.Next;
  end;
end;

I'm allocating a record, filling it with info from the database and then adding the node. You can also cast an integer to a pointer and add it as the object pointer. You can then cast it back to an integer and retrieve the information associated with the node.

Here's an example of getting the info back out of the node:

SelectedNode := SelectedNode.GetFirstChild;
while SelectedNode <> nil do
begin
  if PNodeType(SelectedNode.data)^.RecInfo = FindPatient then
    break;
  SelectedNode := SelectedNode.GetNextSibling;
end;


Solve 2:

If you have a two level tree (node -> subnodes(your_reports)). To determine what item is selected use property TTreeView.Selected:

procedure TForm1.PrintButtonClick(Sender: TObject);
var
  SelectedNode: TTreeNode;
  i: integer;
begin
  SelectedNode := TTreeView1.Selected;
  for i := 0 to SelectedNode.Count - 1
  begin
    if SelectedNode.Item[i].Selected then
      MyPrintReport_procedure(Item[i].Text);
  end;
end;

Sort a TTreeView so that it displays folders first and files second

Problem/Question/Abstract:

I'm populating a treeview from a folder location. At this moment I know how to scan that folder for files and other folders. How can I perform a search so that the items get grouped first the folders and then the files (like Windows Explorer)?

Answer:

You have basically two options:

Do two separate scans, one for folders only, one for files only. This way the treeview gets populated in two chunks. But the two sections will not be sorted alphabetically or so, since the order in which Findfirst/FindNext retrieves the files/folders is undefined (or better: nobody outside MS knows how it is defined ).

or

Sort the treeview after you have populated it using a single scan. By blocking the treeview from redrawing while you populate it (Items.beginUpdate/items.endupdate) you can do populating and sorting without any visual upheaval.

You do the sorting by calling the handling CustomSort method of the treeview. There are two ways to use it, you can hand it a custom comparison function or you can let it call the treeviews OnCompare event to get a descision fromn you which node of a pair to consider "larger". The second method may be easier for you, so you would construct you treeview population code like

{ ... }
treeview1.items.beginupdate;
try
  PopulateTreeView;
  treeview1.CustomSort(nil, 0);
finally
  treeview1.items.endupdate;
end;
{ ... }

and handle the OnCompare event to compare two nodes. The comparison would inspect two items of data for each node: whether it is a folder node or not, and the nodes Text. So you need some way to indicate that a node stands for a folder. You could use the nodes Data property for that, e.g. store Pointer(1) into it for a folder and Nil (Pointer(0)) for a file. In this case the compare event handler would be this:

procedure TForm1.TreeView1Compare(Sender: TObject; Node1, Node2: TTreeNode;
  Data: Integer; var Compare: Integer);
begin
  if node1.Data = node2.Data then
    compare := AnsiCompareText(Node1.Text, NOde2.Text)
  else if Assigned(node1.data) then
    compare := -1 {folders sort before files}
  else
    compare := 1;
end;

How to get track information from an Audio CD

Problem/Question/Abstract:

How to get track information from an Audio CD

Answer:

Solve 1:

This gets the audio tracks from an Audio CD and puts them in a TMemo:


unit frmMain;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    function IsAudioCD(Drive: char): bool;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.IsAudioCD(Drive: char): bool;
var
  DrivePath: string;
  MaximumComponentLength: DWORD;
  FileSystemFlags: DWORD;
  VolumeName: string;
begin
  Result := false;
  DrivePath := Drive + ':\';
  if GetDriveType(PChar(DrivePath)) = DRIVE_CDROM then
  begin
    SetLength(VolumeName, 64);
    GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
      MaximumComponentLength, FileSystemFlags, nil, 0);
    if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
      Result := True;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if IsAudioCD(' D ') then
    showmessage('Cd is an audio cd')
  else
    showmessage('Cd is not an audio cd');
end;

procedure TForm1.Button3Click(Sender: TObject);
type
  TDWord = record
    High: Word;
    Low: Word;
  end;
var
  msp: TMCI_INFO_PARMS;
  MediaString: array[0..255] of char;
  ret: longint;
  I: integer;
  StatusParms: TMCI_STATUS_PARMS;
  MciSetParms: TMCI_SET_PARMS;
  MciOpenParms: TMCI_OPEN_PARMS;
  aDeviceID: MCIDEVICEID;

  function GetTheDeviceID: MCIDEVICEID;
  begin
    FillChar(MciOpenParms, SizeOf(MciOpenParms), #0);
    try
      MciOpenParms.lpstrDeviceType := 'cdaudio';
      ret := mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE + MCI_OPEN_SHAREABLE,
        LongInt(@MciOpenParms));
      Result := MciOpenParms.wDeviceID;
    except
      on E: Exception do
      begin
        Result := 0;
        showmessage('error receiving deviceIDt' + #13 + SysErrorMessage(GetLastError)
          + #13 + E.Message);
      end;
    end;
  end;

  function GetTrackInfo(const uMsg: UInt; const fdwCommand: DWord;
    const dwItem: DWord; const dwTrack: DWord): string;
  begin
    Result := 'Did not work...';
    FillChar(MediaString, SizeOf(MediaString), #0);
    FillChar(StatusParms, SizeOf(StatusParms), #0);
    StatusParms.dwItem := dwItem;
    StatusParms.dwTrack := dwTrack;
    ret := mciSendCommand(aDeviceID, uMsg, fdwCommand, longint(@StatusParms));
    if Ret = 0 then
      Result := IntToStr(StatusParms.dwReturn);
  end;

  procedure SetTimeInfo;
  begin
    FillChar(MciSetParms, SizeOf(MciSetParms), #0);
    MciSetParms.dwTimeFormat := MCI_FORMAT_MSF;
    ret := mciSendCommand(aDeviceID {Mp.DeviceId}, MCI_SET, MCI_SET_TIME_FORMAT,
      longint(@MciSetParms));
    if Ret <> 0 then
      Showmessage('Error convering timeformat...');
  end;

begin
  Memo1.Clear;
  aDeviceID := GetTheDeviceID;
  Application.ProcessMessages;
  Memo1.Lines.Add('Track info  :');
  SetTimeInfo;
  Memo1.Lines.Add('Tracks: ' + GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
    MCI_STATUS_NUMBER_OF_TRACKS, 0));
  Memo1.Lines.Add(' ');
  for I := 1 to StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
    MCI_STATUS_NUMBER_OF_TRACKS, 0)) do
  begin
    Memo1.Lines.Add('Track ' + IntToStr(I) + '  :  ' + IntToStr(MCI_MSF_MINUTE
      (StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM +
      MCI_TRACK, MCI_STATUS_LENGTH, I)))) + ':' +
      IntToStr(MCI_MSF_SECOND(StrToInt(GetTrackInfo(MCI_STATUS,
      MCI_STATUS_ITEM + MCI_TRACK, MCI_STATUS_LENGTH, I)))));
  end;
  Application.ProcessMessages;
end;

end.


Solve 2:

To get the number of tracks and the length of the current track that is playing, use this code :


uses
  mmsystem;

procedure GetInfo(mp: TMediaPlayer);
var
  Trk, Min, Sec: word;
begin
  with mp do
  begin
    Trk := MCI_TMSF_TRACK(Position);
    Min := MCI_TMSF_MINUTE(Position);
    Sec := MCI_TMSF_SECOND(Position);
  end;
  label1.caption := Format('%.2d/%.2d %.2d:%.2d', [Trk, mp.tracks, min, sec]);
end;


And if you would like to check for an audio CD, try this code:


function IsAudioCD(Drive: char): bool;
var
  DrivePath: string;
  MaximumComponentLength: DWORD;
  FileSystemFlags: DWORD;
  VolumeName: string;
begin
  Result := false;
  DrivePath := Drive + ':\';
  if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
    exit;
  SetLength(VolumeName, 64);
  GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
    MaximumComponentLength, FileSystemFlags, nil, 0);
  if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
    result := true;
end;

Determine the graphic format of a file

Problem/Question/Abstract:

Is it possible to determine the graphic format of a file without the use of the extension, e.g. given a extension-less file, is it possible to determine whether it is BMP, JPEG or some other file that we can determine using some signature for that type?

Answer:

You can determine it without extention. Below is a function that reads the file header and determines the type.

function PhysicalResolveFileType(AStream: TStream): Integer;
var
  p: PChar;
begin
  Result := 0;
  if not Assigned(AStream) then
    Exit;
  GetMem(p, 10);
  try
    AStream.Position := 0;
    AStream.Read(p[0], 10);
    {bitmap format}
    if (p[0] = #66) and (p[1] = #77) then
      Result := 1;
    {tiff format}
    if ((p[0] = #73) and (p[1] = #73) and (p[2] = #42) and (p[3] = #0)) or
      ((p[0] = #77) and (p[1] = #77) and (p[2] = #42) and (p[3] = #0)) then
      Result := 2;
    {jpg format}
    if (p[6] = #74) and (p[7] = #70) and (p[8] = #73) and (p[9] = #70) then
      Result := 3;
    {png format}
    if (p[0] = #137) and (p[1] = #80) and (p[2] = #78) and (p[3] = #71) and
      (p[4] = #13) and (p[5] = #10) and (p[6] = #26) and (p[7] = #10) then
      Result := 4;
    {dcx format}
    if (p[0] = #177) and (p[1] = #104) and (p[2] = #222) and (p[3] = #58) then
      Result := 5;
    {pcx format}
    if p[0] = #10 then
      Result := 6;
    {emf format}
    if (p[0] = #215) and (p[1] = #205) and (p[2] = #198) and (p[3] = #154) then
      Result := 7;
    {emf format}
    if (p[0] = #1) and (p[1] = #0) and (p[2] = #0) and (p[3] = #0) then
      Result := 7;
  finally
    Freemem(p);
  end;
end;

Create a form with a border but without a caption

Problem/Question/Abstract:

How to create a form with a border but without a caption

Answer:

{ ... }
type
  TForm1 = class(TForm)
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited;
  {check if caption is set}
  if (Params.Style and WS_CAPTION) <> 0 then
  begin
    {delete caption}
    Params.Style := Params.Style xor WS_CAPTION;
    {Required: add popup style}
    Params.Style := Params.Style or WS_POPUP;
  end;
end;

How to highlight alternate rows in a TListView

Problem/Question/Abstract:

How to highlight alternate rows in a TListView

Answer:

The following will draw all alternate lines with yellow text on blue background. It uses the OnAdvancedCustomDraw events of the listview. As a bonus you get full highlighting of selected lines.

procedure CheckPaintstage(Stage: TCustomDrawStage; itemIndex: Integer; canvas:
  TCanvas);
begin
  if Stage in [cdPrePaint, cdPreErase] then
  begin
    if Odd(itemIndex) then
    begin
      Canvas.Brush.Color := clBlue;
      if Stage = cdPrepaint then
        Canvas.Font.color := clYellow;
    end
  end;
end;

procedure TForm1.ListView1AdvancedCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
begin
  if not (cdsSelected in State) then
    CheckPaintstage(Stage, item.Index, sender.canvas)
  else
    Sender.Canvas.Brush.Color := clHighlight;
end;

procedure TForm1.ListView1AdvancedCustomDrawSubItem(Sender: TCustomListView;
  Item: TListItem; SubItem: Integer; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
begin
  if not (cdsSelected in State) then
    CheckPaintstage(Stage, item.Index, sender.canvas)
  else
  begin
    Sender.Canvas.Font.Color := clHighlightText;
    Sender.Canvas.Brush.Color := clHighlight;
  end;
end;

Cross-Site Scripting Protection (aka Encoding and Filtering HTML)

Problem/Question/Abstract:

In this article I&#8217;ll present a unit that can both Encode data for display in an HTML document, and also ensure that invalid characters (filtering) that can be used for cross-site scripting are prevented from entering.

Answer:

Cross-Site Scripting Protection (aka Encoding and Filtering HTML)

In this article I&#8217;ll present a unit that can both Encode data for display in an HTML document, and also ensure that invalid characters (filtering) that can be used for cross-site scripting are prevented from entering.

For more information about cross-site scripting and malicious code problems, please visit:
http://www.cert.org/tech_tips/malicious_code_mitigation.html/

Overview

To summarize the article, any HTML data that is presented to the user from disparate data sources (which may not always be in your control) should be filtered of characters that can affect the display of HTML or allow embedded script viruses.  

Filtering Data

For example, let&#8217;s say that you have a form on your web site that allows a user to enter a contest, on this form they enter their email address and first name and then hit submit which adds a record to your database. Of course, several validity checks, such as size of contest, etc. will take place, but in most cases the data is not checked for malicious HTML code. Continuing this example, lets say you have another program that will send out an HTML e-mail, which contains the first name and e-mail address (basically a mail merge).

I as a malicious user can enter the contest submitting my target&#8217;s e-mail address, and a small virus (not necessarily harmful) in the first name field; when the e-mail is sent out through the second program the recipient can be passed code to be executed in their web-browser against their will (and with the recent sting of Internet Explorer and Microsoft Office bugs, this could be a major issue).

This scenario can be fixed by simply filtering out the few characters that should not be allowed if the data is to be ultimately displayed in a web-browser.

The function, in the abHTMLFilters unit, FilterData will delete any characters that should not be allowed in the data (based on CERT&#8217;s recommendation).

Encoding Data

The flip side of filtering is encoding. Encoding allows you to safely display any code, which would normally be interpreted by the web-browser as formatting instructions or script, as text. As a simple example, this can be used to display the source of an HTML file in a browser.

The function, in the abHTMLFilters unit, EncodeData will encode any characters that should not be allowed in the data (based on CERT&#8217;s recommendation) with its HTML equivalent so it can be displayed.

I hope you found this article and function to be useful; I&#8217;d love to hear your comments, suggestions, etc.

The following is the source code for the functions described above, feel free to use the code in your own programs, but please leave my name and address intact!

// ---------------------------ooo------------------------------ \\
// &copy;2000 David Lederman
// dlederman@internettoolscorp.com
// ---------------------------ooo------------------------------ \\
unit abHTMLFilters;

interface

function FilterData(Data: string): string;
function EncodeData(Data: string): string;

implementation

const
  IsBadChar: array[0..255] of Boolean = (
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, true, true, false, false, true, true, true, true, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, true, true, false, true, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false, false, false, false, false, false, false, false, false,
    false, false, false);
const
  ReplaceBadChars: array[0..255] of string = (
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '&#34;', '&#35;', '', '', '&#38;', '&#39;', '&#40;', '&#41;', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '&#59;', '&#60;', '', '&#62;', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '', '', '', '', '', '', '', '', '',
    '', '', '');

  // ---------------------------ooo------------------------------ \\
  // This function will filter out all dangerous data for web
  // display.
  // ---------------------------ooo------------------------------ \\

function FilterData(Data: string): string;
var
  i, DataLen, ActualLen: Integer;
begin
  Result := '';
  // Get the data length
  DataLen := Length(Data);
  // Check if we can escape early
  if DataLen = 0 then
    Exit;
  for i := 1 to DataLen do // Iterate
  begin
    if not IsBadChar[Ord(Data[i])] then
      Result := Result + Data[i];
  end; // for
end;
// ---------------------------ooo------------------------------ \\
// This function will encode (for display) all dangerous data
// for weg display.
// ---------------------------ooo------------------------------ \\

function EncodeData(Data: string): string;
var
  i, DataLen, ActualLen: Integer;
begin
  Result := '';
  // Get the data length
  DataLen := Length(Data);
  // Check if we can escape early
  if DataLen = 0 then
    Exit;
  for i := 1 to DataLen do // Iterate
  begin
    if not IsBadChar[Ord(Data[i])] then
    begin
      Result := Result + Data[i];
    end
    else
    begin
      Result := Result + ReplaceBadChars[Ord(Data[i])];
    end;
  end; // for
end;

end.

Change the default printer in Windows

Problem/Question/Abstract:

How can I change the default printer in Windows?

Answer:

If you want to change the the default printer in Windows OS, you must change the device key in the Windows section of the WIN.INI. After that you must send a WM_WININICHANGE message:

var
  strIni: array[0..MAX_PATH] of Char;
  arrWindows: array[0..64] of Char;
begin
  GetWindowsDirectory(strIni, SizeOf(strIni));
  StrCat(strIni, '\win.ini');
  with TIniFile.Create(strIni) do
  try
    WriteString('windows', 'device', 'HP LaserJet 4 Plus,HPPCL5MS,LPT1:');
  finally
    Free;
  end;

  StrCopy(arrWindows, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@arrWindows));
end;

CDROM notification (CDROM inserted or ejected)

Problem/Question/Abstract:

When the user inserts a CD in Drive E:, my application should do something. How can I get notified about a new CD being inserted?

Answer:

When a new CD is inserted, Windows posts to all processes the WM_DEVICECHANGE message. Its wParam value contain the information you need:

OUTPUT -> $8004;
INSERT -> $8000;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure CDROM_Notification(var msg: TMessage);
      message WM_DEVICECHANGE;
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  CD_OUTPUT = $8004;
  CD_INPUT = $8000;

procedure TForm1.CDROM_Notification(var msg: TMessage);
begin
  if msg.wParam = CD_INPUT then
    ShowMessage('There is a new CD.')
  else if msg.wParam = CD_OUTPUT then
    ShowMessage('CD was ejected.');
end;

end.

Convert TColor values to hex strings

Problem/Question/Abstract:

How to convert TColor values to hex strings

Answer:

HexStr := Format('#%.2x%.2x%.2x;', [GetRValue(MyColor), GetGValue(MyColor),
  GetBValue(MyColor)]);

Read a registry entry of type REG_MULTI_SZ

Problem/Question/Abstract:

How to read a registry entry of type REG_MULTI_SZ

Answer:

REG_MULTI_SZ is a registry type holding multiple strings. This function reads the value into a TStrings object and returns true if successful.

function ReadREG_MULTI_SZ(const HK: HKey; const k, v: string; ts: TStrings): boolean;
var
  vType: DWORD;
  vLen: DWORD;
  p, buffer: PChar;
  key: HKEY;
begin
  result := false;
  ts.Clear;
  if (RegOpenKeyEx(HK, PChar(k), 0, KEY_READ, key) = ERROR_SUCCESS) then
  begin
    SetLastError(RegQueryValueEx(key, PChar(v), nil, @vType, nil, @vLen));
    if (GetLastError = ERROR_SUCCESS) and (vType = REG_MULTI_SZ) then
    begin
      GetMem(buffer, vLen);
      try
        RegQueryValueEx(key, PChar(v), nil, nil, PBYTE(buffer), @vLen);
        p := buffer;
        while (p^ <> #0) do
        begin
          ts.Add(p);
          Inc(p, lstrlen(p) + 1)
        end;
      finally
        FreeMem(buffer)
      end;
      result := true;
    end;
  end;
end;

Example to read the 'Pagingfiles' value into a TMemo:

procedure TForm1.Button1Click(Sender: TObject);
var
  k, val: string;
begin
  k := 'SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management';
  val := 'Pagingfiles';
  ReadREG_MULTI_SZ(HKEY_LOCAL_MACHINE, k, val, Memo1.Lines);
end;

Compare two files and find the differences

Problem/Question/Abstract:

Does anyone know of sample code that compares two files and indicates if there is a difference or not (like FC)? I could use filestreams and compare bit by bit but I'm hoping someone has done this in a more optimized fashion.

Answer:

Use CreateFileMapping and compare pointers. Look at my unfinished unit below for an example:

unit findin;

interface

uses
  Windows, SysUtils, findstr;

type
  TFindInFile = class;

  TFindIn = class
  protected
    FFindInFile: TFindInFile;
    FHandle: THandle;
    function GetPartNum: Integer; virtual; abstract;
    function GetPartLen(Index: Integer): Cardinal; virtual; abstract;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); virtual;
    destructor Destroy; override;
    function CanUseMem: Boolean; virtual; abstract;
    function UseMemSize: Cardinal; virtual; abstract;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; virtual; abstract;
    property PartNum: Integer read GetPartNum;
    property PartLen[Index: Integer]: Cardinal read GetPartLen;
  end;

  TFindInClass = class of TFindIn;

  TBMSearchFunc = function(var Buffer; BufLength: Cardinal; var BT: TBMTbl;
    MatchString: PAnsiChar; var Pos: Cardinal): Boolean;

  TFindInFile = class
  protected
    FFindIn: TFindIn;
    FFindInClass: TFindInClass;
    FFindStrParams: PFindStrParams;
    FMemHandle: THandle;
    FMem: Pointer;
    FStrLen: Cardinal;
    FDriveTp: UINT;
    FBMSearchFunc: TBMSearchFunc;
    function GetDriveTp(Root: string): UINT;
  public
    constructor Create(FindStrParams: PFindStrParams);
    destructor Destroy; override;
    function Find(FileName: string): Cardinal;
    function SwitchToRoot(Root: string): Boolean; virtual;
  end;

  TFindInHDD = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FMapPtr: Pointer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    destructor Destroy; override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

  PIntArr = ^TIntArr;
  TIntArr = array[0..1] of Cardinal;

  TFindInRemovable = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FPartNum: Integer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

implementation

resourcestring
  SInvalidDrive = 'Invalid drive - "%s".';

  { TFindIn }

constructor TFindIn.Create(FindInFile: TFindInFile; FileName: string);
begin
  inherited Create;
  FFindInFile := FindInFile;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ,
    nil, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0);
  if FHandle = INVALID_HANDLE_VALUE then
    RaiseLastWin32Error;
end;

destructor TFindIn.Destroy;
begin
  if FHandle <> 0 then
    CloseHandle(FHandle);
  inherited Destroy;
end;

{ TFindInHDD }

constructor TFindInHDD.Create(FindInFile: TFindInFile; FileName: string);
var
  hFile: THandle;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  hFile := CreateFileMapping(FHandle, nil, PAGE_READONLY, 0, 0, nil);
  CloseHandle(FHandle);
  FHandle := hFile;
  if FHandle <> 0 then
  begin
    FMapPtr := MapViewOfFile(FHandle, FILE_MAP_READ, 0, 0, 0);
    if FMapPtr = nil then
      RaiseLastWin32Error;
  end
  else
    RaiseLastWin32Error;
end;

destructor TFindInHDD.Destroy;
begin
  if FMapPtr <> nil then
    UnmapViewOfFile(FMapPtr);
  inherited Destroy;
end;

function TFindInHDD.GetPartNum: Integer;
begin
  Result := 1;
end;

function TFindInHDD.GetPartLen(Index: Integer): Cardinal;
begin
  Result := FSize;
end;

function TFindInHDD.GetPart(Index: Integer; Len: Cardinal): Pointer;
begin
  Result := FMapPtr;
end;

function TFindInHDD.CanUseMem: Boolean;
begin
  Result := False;
end;

function TFindInHDD.UseMemSize: Cardinal;
begin
  Result := 0;
end;

{ TFindInRemovable }

constructor TFindInRemovable.Create(FindInFile: TFindInFile; FileName: string);
var
  S: Cardinal;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  if FSize = $FFFFFFFF then
    RaiseLastWin32Error;
  S := UseMemSize - Pred(FFindInFile.FStrLen);
  FPartNum := FSize div S;
  if FSize mod S <> 0 then
    Inc(FPartNum);
end;

function TFindInRemovable.GetPartNum: Integer;
begin
  Result := FPartNum;
end;

function TFindInRemovable.GetPartLen(Index: Integer): Cardinal;
begin
  Result := UseMemSize;
  if (Index = Pred(FPartNum)) and (FSize mod (Result - FFindInFile.FStrLen) <> 0) then
    Result := FSize - (Result - Pred(FFindInFile.FStrLen)) * Pred(FPartNum);
end;

function TFindInRemovable.GetPart(Index: Integer; Len: Cardinal): Pointer;
var
  Dist: ULONG;
  Reading: DWORD;
begin
  Result := FFindInFile.FMem;
  Dist := Index * (UseMemSize - Pred(FFindInFile.FStrLen));
  SetFilePointer(FHandle, Dist, nil, FILE_BEGIN);
  if not ReadFile(FHandle, Result^, Len, Reading, nil) then
    RaiseLastWin32Error;
end;

function TFindInRemovable.CanUseMem: Boolean;
begin
  Result := True;
end;

function TFindInRemovable.UseMemSize: Cardinal;
begin
  Result := 8; {512 * 1024;}
end;

{ TFindInFile }

function Max(V1, V2: Integer): Integer; assembler; register;
asm
  CMP  EAX,EDX
  JG   @@1
  MOV  EAX,EDX
@@1:
end;

constructor TFindInFile.Create(FindStrParams: PFindStrParams);
var
  I: Integer;
begin
  inherited Create;
  FDriveTp := $FFFFFFFF;
  FFindStrParams := FindStrParams;
  if FFindStrParams^.CaseSensitive then
    FBMSearchFunc := BMSearch
  else
    FBMSearchFunc := BMSearchUC;
  FStrLen := 0;
  for I := 0 to Pred(FFindStrParams^.Substr.Count) do
    FStrLen := Max(FStrLen, length(FFindStrParams^.Substr[I]));
end;

destructor TFindInFile.Destroy;
begin
  if FMemHandle <> 0 then
  begin
    GlobalUnlock(FMemHandle);
    GlobalFree(FMemHandle);
  end;
  inherited Destroy;
end;

function TFindInFile.GetDriveTp(Root: string): UINT;
begin
  Result := GetDriveType(PChar(ExtractFileDrive(Root) + '\'));
end;

function TFindInFile.Find(FileName: string): Cardinal;
var
  I, J, K: Integer;
  L: Cardinal;
  P: Pointer;
  PI: PFindStrInfo;
  BMSFunc: TBMSFunc;
begin
  Result := NotFound;
  FFindIn := FFindInClass.Create(Self, FileName);
  try
    if FFindIn.CanUseMem and (FMem = nil) then
    begin
      FMemHandle := GlobalAlloc(GMEM_MOVEABLE, FFindIn.UseMemSize);
      if FMemHandle = 0 then
        RaiseLastWin32Error;
      FMem := GlobalLock(FMemHandle);
    end;
    for I := 0 to Pred(FFindIn.PartNum) do
      for J := 0 to Pred(FFindStrParams^.Substr.Count) do
      begin
        L := FFindIn.PartLen[I];
        P := FFindIn.GetPart(I, L);
        Result := FindString(P^, L, J, FFindStrParams);
        PI := PFindStrInfo(FFindStrParams.Substr.Objects[J]);
        if FBMSearchFunc(P^, L, PI^.BMTbl, PI^.FindS, Result) then
        begin
          if I > 0 then
            for K := 1 to I - 1 do
              Inc(Result, FFindIn.PartLen[K]);
          Exit;
        end;
      end;
  finally
    FFindIn.Free;
  end;
end;

function TFindInFile.SwitchToRoot(Root: string): Boolean;
var
  Tp: UINT;
begin
  Tp := GetDriveTp(Root);
  if Tp <> FDriveTp then
    case Tp of
      0, 1: Exception.CreateFmt(SInvalidDrive, [Root]);
      DRIVE_FIXED: FFindInClass := TFindInHDD;
    else
      {DRIVE_REMOVABLE:
       DRIVE_REMOTE:
       DRIVE_CDROM:
       DRIVE_RAMDISK:}
      FFindInClass := TFindInRemovable;
    end;
end;

end.