Controlling the Field Display in a TDBGrid

Problem/Question/Abstract:

I am developing a database/intranet package for which I need to use a grid based on a TQuery, but I only need a few of the fields to show up in the grid. The wizard won't let me do it? What am I missing/overlooking?

Answer:

This is a stumbling block for a lot of people. And it's not really due to missing something, it's just due to unfamiliarity with the way the data-aware components work. Think of the way data is displayed in Delphi as a layer cake:

Layer 4 Data-aware Component
Layer 3 DataSource
Layer 2 Field-link (TField)
Layer 1 DataSet

The top layer is the component that displays the data; in your case, the TDBGrid. It's connected to a DataSource component, which in turn is connect to TDataLinks or TFields. These are then connected to the underlying dataset.

You might think that the "visibility" of data is controlled by the DBGrid. Actually, data visibility is controlled at a much lower level, the TField level/Data-link level. I won't go into TDataLink, because that's a bit more on the esoteric side of things, but I will say this: If you don't use TField definitions for your dataset, Delphi will default to use the data links, which means that all your columns will be displayed. This is probably the behavior you're seeing right now.

However, if you define TFields for your dataset component, only the ones you add will be displayed in your grid or, if you've added all fields from the dataset to have TField definitions, only those fields that have their Visible property set to True will have their data displayed.

But how do you do define TFields for a dataset in the first place?

Well, I'm assuming that you have a TDBGrid, a TDataSource and a TQuery dropped onto your form. I'm further assuming that you've set up your query. To get at the TFields, all you have to do is double-click on the TQuery component. This will bring up the Fields Editor. When you do this, it'll be blank, but don't worry. Press Ctrl-A to add fields, and an "Add Fields" dialog box will pop up, containing a list of available fields that can have TField definitions attached to them. By default, all of the fields are selected. Press OK if you want all of them, or select only the fields you want to display.

Once you've selected your fields, you'll see them listed in the fields editor. Click on one of the fields. Look in the Object Inspector. You'll see a bunch of properties associated with the field. In particular, look at the Visible property. By default, it will be set to true. If you don't want the data to be displayed, set the property to false.

That's it in a nutshell. Refer to the online help for a more detailed explanation. Also, the Database Application Developer's Guide that came with your Delphi manual set will provide you with more robust information than I've given here.

How to extract an audio stream of an *.avi file

Problem/Question/Abstract:

How can I extract an audio stream of an *.avi file?

Answer:

Note, you must use VfW.pas. You may find this file somewhere in the internet or simply write me an email. In addition, I was not able to test this code under Delphi 5.x or lower. Only Delphi 6.x. Please send me a piece of information, if you can test this for me. Thanks


uses VfW;

function CallBack(i: int): BOOL; pascal;
begin
  Label1.Caption := IntToStr(i) + '%';
  Application.ProcessMessages;
  Result := False;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  PFile: IAviFile;
  PAvi: IAviStream;
  plpOptions: PAviCompressOptions;
begin
  AviFileInit;
  if AviFileOpen(PFile, 'C:\test.avi', 0, nil) <> 0 then
  begin
    ShowMessage('Couldn'' t open * .avi!');
    Exit;
  end;
  if AviFileGetStream(PFile, PAvi, StreamTypeAudio, 0) <> 0 then
  begin
    ShowMessage('Couldn' t load audio stream!');
      AviFileExit;
      Exit;
  end;
  if AviSaveV('C:\test.wav', nil, @CallBack, 1, PAvi, plpOptions) <> 0 then
  begin
    ShowMessage('Couldn'' t save * .wav - file!');
    AviStreamRelease(PAvi);
    AviFileExit;
    Exit;
  end;
  AviStreamRelease(PAvi);
  AviFileExit;
end;

How to determine how many lines a TMemo is capable of showing

Problem/Question/Abstract:

How to determine how many lines a TMemo is capable of showing

Answer:

Here is the short and elegant way that works (most of the time):

function TForm1.MemoLinesShowing(memo: TMemo): integer;
var
  R: TRect;
begin
  Memo.Perform(EM_GETRECT, 0, Longint(@R));
  Result := (R.Bottom - R.Top) div Canvas.TextHeight('XXX');
end;

The problem with this code is that the TForm and the TMemo must both be using the same font. If the fonts are different, then the calculations are not accurate.

You have to retrieve the font height by selecting it into a device context. The reason you cannot use the font Height provided by Delphi is because Delphi caches the font infomation but doesn't acutally select the font into the DC (canvas) until it is actually going to draw something. This occurs in the painting event of the memo.

To get around this problem, you can get the memo's device context using the Windows API and get the font information from the device context to calculate the text height. The function below illustrates this process:

function TForm1.MemoLinesShowingLong(Memo: TMemo): integer;
var
  Oldfont: HFont; {the old font}
  DC: THandle; {Device context handle}
  i: integer; {loop variable}
  Tm: TTextMetric; {text metric structure}
  TheRect: TRect;
begin
  DC := GetDC(Memo.Handle); {Get the memo's device context}
  try
    {Select the memo's font}
    OldFont := SelectObject(DC, Memo.Font.Handle);
    try
      GetTextMetrics(DC, Tm); {Get the text metric info}
      Memo.Perform(EM_GETRECT, 0, longint(@TheRect));
      Result := (TheRect.Bottom - TheRect.Top) div (Tm.tmHeight +
        Tm.tmExternalLeading);
    finally
      SelectObject(DC, Oldfont); {Select the old font}
    end;
  finally
    ReleaseDC(Memo.Handle, DC); {Release the device context}
  end;
end;

How can I find out / set the backgroundcolor of the site in TWebbrowser?

Problem/Question/Abstract:

How can I find out / set the backgroundcolor of the site in TWebbrowser?

Answer:

//You need a TWebbrowser and 3 TButtons

// First load a page

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('http://dkb.kastu.lt');
end;

// Show the background color

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage(WebBrowser1.OleObject.Document.bgColor);
end;

// Set the background color

procedure TForm1.Button3Click(Sender: TObject);
begin
  WebBrowser1.OleObject.Document.bgColor := '#000000';
end;

How can I check, whether the side in TWebbrowser is on local HD?

Problem/Question/Abstract:

How can I check, whether the side in TWebbrowser is on local HD?

Answer:

// You need: A TWebbrowser, TButton, TLabel

procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate('file:///c:/test.txt');
end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if Webbrowser1.Oleobject.Document.Location.Protocol = 'file:' then
  begin
    label1.Caption := 'The file is on a local drive!';
  end;
end;

How to capture the WM_CUT, WM_CLEAR and WM_PASTE messages in a TComboBox

Problem/Question/Abstract:

By hooking into the WndProc I can listen to the messages generated for TWinControls. I am looking for the WN_CUT, WM_PASTE and WM_CLEAR so that I can lock a record before the cut, paste or clear change occurs. The TComboBox does not generate these events when the Style is csDropDown. Any way to capture these events?

Answer:

Override the ComboWndProc method �n a class derived from TCombobox. Example:

unit Unit1;

interface

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

type
  TCombobox = class(stdctrls.TComboBox)
  protected
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
      ComboProc: Pointer); override;
  end;
  TForm1 = class(TForm)
    ComboBox1: TComboBox;
    Memo1: TMemo;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TCombobox }

procedure Report(const S: string);
begin
  form1.memo1.lines.add(S);
end;

procedure TCombobox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd;
  ComboProc: Pointer);
begin
  inherited;
  case message.Msg of
    WM_CUT: Report('CUT');
    WM_PASTE: Report('PASTE');
    WM_CLEAR: Report('CLEAR');
  end;
end;

end.

How to use a blob field to hold a record structure

Problem/Question/Abstract:

I want to use a blob field to hold a record structure. ErrsTblErrs_Data has a blobType of "ftBlob"

type
  LogiRec = record
    LOGI_REG_NUM: array[1..9] of Char;
    LOGI_ENT_DATE: array[1..10] of Char;
    LOGI_Batch_num: array[1..6] of Char;
    LOGI_Trac_num: array[1..6] of Char;
    {...}
  end;

var
  Buffer: array[0..600] of char;
  Logi: LogiRec absolute Buffer;
  {...}
  {This works to get the data in}
  ErrsTblErrs_Data.asstring := Buffer;
  {This doesn't works to get the data out}
  Buffer := ErrsTblErrs_Data.asstring;

Is there a more elegant way of doing this?

Answer:

Try something like this to record the data:

var
  b: TBlobStream;
begin
  Table1.Append;
  b := TBlobStream.Create(Table1MyBlobField, bmWrite);
  try
    b.Write(MyRecord, sizeof(MyRecord));
  finally
    b.Free;
  end;
  Table1.Post;
end;

To read back:

var
  b: TBlobStream;
begin
  Table1.First;
  repeat
    begin
      b := TBlobStream.Create(Table1MyBlobField, bmRead);
      try
        b.seek(0, 0);
        b.Read(MyRecord, sizeof(MyRecord));
      finally
        b.Free;
      end;
    end;
  until Table1.EOF;
end;

Getting file system information

Problem/Question/Abstract:

How do I use WinAPI functions like GetVolumeInformation to get information about my system?

Answer:

Now and then a user comes up with a question that intrigues me so much that I end up creating a full-blown application as well as article around the question. Such is the case with this article.

A user sent me an e-mail asking how to employ the WinAPI call GetVolumeInformation. I knew about this function, but had never really used it. But when I referenced the function in the help file, which I was supposed to use as material to answer the original question, I ended up following the various branches of hyperlinks off of the topic, struck by the thought that with a couple of other functions, I could create a program that could provide me with practically instant information about my file system. And that's what I did. Figure 1 shows the program in action.



The information that's displayed is the result of three WinAPI calls. Table 1 describes what was used and for what purpose:

Function
Usage
GetVolumeInformation
This handy function fills some variables passed as formal parameters to give you information such as the disk volume name, the file system employed, and various things the drive supports such as compression and long file names.
GetDiskFreeSpace
GetDiskFreeSpace fills four variables passed as formal parameters which provide information on the following: Sectors/Cluster, Bytes/Cluster, Free Clusters, and Total Clusters. A little arithmetic will get you the total and free number of megabytes on the hard disk.
GetDriveType
This returns a DWORD (4-byte assembler symbol that can be read as a short but is typically used as a bit array) that indicates the type of drive of the drive passed to it as a formal parameter.


These functions provide the most common information about your file system and the drive for which you want to get information. But since they're WinAPI calls, it's not quite readily apparent how to use them.

The WinAPI Dilemma

If you've followed this column for a while, and have read my articles dealing with WinAPI calls, you know how I feel about it. I have a love-hate relationship with the WinAPI. I love it because there's so much buried within it, yet I hate it, because it's big and employing its functions is not the easiest thing because of the type conversions and C language conventions. But for low-level Windows stuff, the WinAPI is the way to go. Remember, the VCL is pretty much one big wrapper for the WinAPI.

I've said the following before as well: Be prepared to have some references handy when using the WinAPI. Specifically, these are the WINDOWS.PAS WinAPI wrapper file and the online help. The help file is very important because it will give you explanations of the various formal parameters and return values (if any) for the function. It will also tell you what structures you might need to initialize prior to calling the function. You'll want to have the WINDOWS.PAS file on hand because when you look up function in the help file, you'll notice that it is described in C/C++ conventions. What you have to do is locate the function in WINDOWS.PAS and see what the Object Pascal/Delphi convention is for calling the function. For example, a WinAPI function may define one of its formal parameters as type LPSTR or LPCSTR. If you didn't have WINDOWS.PAS on hand, you'd never know these types translate to PChar. That said, let's look at how I've employed the functions I've used for getting file system information.

Getting at the Information

I used a single method in the main form of the program to get the volume and file system information to display in the various labels and the memo on the main form. Here's a listing of the method; below it, we'll discuss particulars.

procedure TForm1.GetVolInfo;
var
  //Volume Information Variables
  nVNameSer: PDWORD;
  drv: string;
  pVolName: PChar;
  FSSysFlags,
    maxCmpLen: DWord;
  I: Integer;
  pFSBuf: PChar;

  //Drive Information Variables;
  dType: TDrvType;
  SectPerCls,
    BytesPerCls,
    FreeCls,
    TotCls: DWord;

begin
  //initialize vars
  drv := DriveComboBox1.Drive + ':\';
  GetMem(pVolName, MAX_PATH);
  GetMem(pFSBuf, MAX_PATH);
  GetMem(nVNameSer, MAX_PATH);

  //Do some preliminary preparation stuff
  Memo1.Lines.Clear;

  //Now, get the volume information
  GetVolumeInformation(PChar(drv), pVolName, MAX_PATH, nVNameSer,
    maxCmpLen, FSSysFlags, pFSBuf, MAX_PATH);

  //Get descriptions for File System Flags
  for I := 0 to 5 do
  begin
    //do an AND bitwise operation to see if I is in the mask
    if ((FSSysFlags and I) <> 0) then
      case I of
        Ord(fsCaseIsPreserved):
          Memo1.Lines.Add('...preserves case with file names');
        Ord(fsCaseSensitive):
          Memo1.Lines.Add('...supports case sensitive file names');
        Ord(fsUnicodeStoredOnDisk):
          Memo1.Lines.Add('...stores Unicodes as on disk');
        Ord(fsPersistentAcls):
          Memo1.Lines.Add('...preserves and enforces ACLs');
        Ord(fsFileCompression):
          Memo1.Lines.Add('...supports file-based compression');
        Ord(fsVolumeIsCompressed):
          Memo1.Lines.Add('...resides on a compressed volume');
      end;
  end;

  //determine if system supports long file names
  if (maxCmpLen > 8.3) then
    Memo1.Lines.Add('...supports long file names');

  Label6.Caption := StrPas(pVolName);
  Label3.Caption := IntToStr(nVNameSer^);
  Label4.Caption := StrPas(pFSBuf);

  //Get the Drive Type information
  dType := TDrvType(GetDriveType(PChar(drv)));
  case dType of
    dtNotDetermined: Label10.Caption := 'Unable to Determine';
    dtNonExistent: Label10.Caption := 'Does not exist';
    dtRemoveable: Label10.Caption := 'Removable Drive (Floppy)';
    dtFixed: Label10.Caption := 'Fixed Disk';
    dtRemote: Label10.Caption := 'Remote or Network Drive';
    dtCDROM: Label10.Caption := 'CD-ROM Drive';
    dtRamDrive: Label10.Caption := 'RAM Drive';
  end;

  //Get the total and free space on selected drive and
  //display in MBs
  GetDiskFreeSpace(PChar(drv), SectPerCls, BytesPerCls, FreeCls, TotCls);
  Label11.Caption := FormatFloat('0.00', (SectPerCls * BytesPerCls *
    TotCls) / 1000000) + ' MB';
  Label12.Caption := FormatFloat('0.00', (SectPerCls * BytesPerCls *
    FreeCls) / 1000000) + ' MB';

  //Get rid of pointer resources
  FreeMem(pVolName, MAX_PATH);
  FreeMem(pFSBuf, MAX_PATH);
  FreeMem(nVNameSer, MAX_PATH);
end;

The first thing I did in the method was to initialize the variables that required initialization before usage. Whenever you use pointers of any type, they must be initialized and the system must be notified of how much memory will need to be reserved. For PChar this is a simple process of calling GetMem. After you've finished using a pointer, make sure to call FreeMem to release the resources used by the pointer.

Continuing on, after I initialized the variables, I made the call to GetVolumeInformation.  WINDOWS.PAS declares the function as follows:

function GetVolumeInformation(lpRootPathName: PChar;
  lpVolumeNameBuffer: PChar;
  nVolumeNameSize: DWORD;
  lpVolumeSerialNumber: PDWORD;
  var lpMaximumComponentLength,
  lpFileSystemFlags: DWORD;
  lpFileSystemNameBuffer: PChar;
  nFileSystemNameSize: DWORD):
  BOOL; stdcall;

As you can see there are quite a few formal parameters you have to fill in order to make this call. The first parameter, lpRootName, is a null-terminated string that holds the root directory of the drive or volume you want to get information on. As you can see in the code above, I've typecasted the value of the drv string variable, which is merely the value of the Drive property of a TDriveComboBox, plus a semi-colon and backslash, when making the call to GetVolumeInformation.

The second and third parameters have to do with the volume name. lpVolumeNameBuffer is a PChar that will be loaded with the name of the volume, and nVolumeNameSize is the size of the buffer. These two formal parameters are similar to the lpFileSystemNameBuffer and nFileSystemNameSize parameters in that they describe a destination buffer along with its size. Notice that I initialized both pointers' sizes to the numeric constant MAX_PATH and also used this value for nVolumeNameSize and nFileSystemNameSize. MAX_PATH's value is 260, which is probably overkill, but I wanted to use a common, globally defined system constant for initializing the size as opposed to a hard-coded value. In fact, you'll often find the Win32 help file stating that you should use a predefined constant to avoid differences in later versions of the compiler.

lpVolumeSerialNumber is the serial number of the disk on which the volume resides. This is a pointer to a DWORD, so you'll notice that I also initialized memory for it in addition to lpVolumeNameBuffer and lpFileSystemName with GetMem. lpMaximumComponentLength is a parameter you pass by reference; hence the var signfication associated with it. The number that gets returned is maximum file length of a file component, the characters between the backslashes of a path listing.

Finally, lpFileSystemFlags is a DWORD (four-byte Assembler type that is for all intents and purposes the same as a Short) that acts as a bit mask for specific system information. The way that works is there are predefined constants associated in the set of File System Flags. To determine if a particular flag is set in the bit mask, you do a bitwise AND against the flag value's bits. If the return value is one, then the bit is set and the flag is true. There are six file system flags. So in the code, I perform a loop to test each bit position. If a bit is set, I display some text in a memo box. Study the code above to see how I do this. In a nutshell, each successive bit represents a certain file system flag as defined in the online help. If a bit is set, I basically translate this into its associated definition and display it. (BTW, a big thanks goes to Steve Schafer of TeamBorland on CompuServe for his help with the bit mask operations.)

So...

The calls to GetDriveType and GetDiskFreeSpace were far easier to make than GetVolumeInformation. With respect to the call to GetDriveType, notice that in the code listing above I enclosed it in a typecast of TDrvType. This was a custom enumerated type that I declared that held the definitions of the possible drive types that could be encountered when using this function. By performing the typecast, I ensure that the return type, which is a DWORD, will conform to one of my descriptors.

GetDiskFreeSpace was even easier to call than any of the other functions employed by my application. All you do with it is pass the root directory name and four DWORD variables representing the following: Sectors/Cluster, Bytes/Cluster, Free Clusters, and Total Clusters, respectively. Then with a little arithmetic (as shown above) you can get the total and free space available on current volume. That's a snap.

Will you ever use these functions? Probably not very often. However, for getting some quick information about your file system, these are the functions you use. Yes, the Windows API is a bit cumbersome, but hey! this is our environment of choice. And my hunch is, the more you know about it, the better your understanding will be, and the more effective you'll be at writing Windows applications.

Note:There's a demo application available for this Articel

How to remove blocks of text

Problem/Question/Abstract:

Never needed to remove blocks of text delimited by words or place holders from a text? Or comments, included in brackets, from a string? Here is a useful function that does that.

Answer:

Just use this function to remove text between round brackets, or specify a different start/end placeholder to remove what you nees.

function RemoveBlocks(Value: string; BeginWidth: string = '('; EndWith: string = ')'):
  string;
var
  BeginPoint: Integer;
  EndPoint: Integer;
begin
  BeginPoint := Pos(BeginWith, Value);
  EndPoint := Pos(EndWith, Value);
  while ((BeginPoint > 0) and (EndPoint > BeginPoint)) do
  begin
    Delete(Value, BeginPoint, (EndPoint - BeginPoint + 1));
    BeginPoint := Pos(BeginWith, Value);
    EndPoint := Pos(EndWith, Value);
  end;
  Result := Value;
end;

For example, you can remove all paragraphs in a HTML source just using this:

MyHTML := RemoveBlocks(MyHTML, '<', '>');

You can also improve the function by adding a "case-insensitive" function with something like this:

function RemoveBlocks(Value: string; BeginWidth: string = '('; EndWith: string = ')'):
  string;
var
  BeginPoint: Integer;
  EndPoint: Integer;
begin
  BeginWith := LowerCase(BeginWith);
  EndWith := LowerCase(EndWith);
  BeginPoint := Pos(BeginWith, LowerCase(Value));
  EndPoint := Pos(EndWith, LowerCase(Value));
  while ((BeginPoint > 0) and (EndPoint > BeginPoint)) do
  begin
    Delete(Value, BeginPoint, (EndPoint - BeginPoint + 1));
    BeginPoint := Pos(BeginWith, LowerCase(Value));
    EndPoint := Pos(EndWith, LowerCase(Value));
  end;
  Result := Value;
end;

Display text in any angle

Problem/Question/Abstract:

Display text in any angle

Answer:

The following works only with TrueType fonts:


var
  LogFont: TLogFont;
  ...
    GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
  // in 1/10 degrees, 450 = 45 degrees
  LogFont.lfEscapement := Angle * 10;
  Canvas.Font.Handle := CreateFontIndirect(LogFont);

Jump to a certain key in Regedit

Problem/Question/Abstract:

How to jump to a certain key in Regedit?

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure JumpToKey(Key: string);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  ShellAPI;

procedure TForm1.JumpToKey(Key: string);
var
  i, n: Integer;
  hWin: HWND;
  ExecInfo: ShellExecuteInfoA;
begin
  hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
  if hWin = 0 then
    {if Regedit doesn't run then we launch it}
  begin
    FillChar(ExecInfo, 60, #0);
    with ExecInfo do
    begin
      cbSize := 60;
      fMask := SEE_MASK_NOCLOSEPROCESS;
      lpVerb := PChar('open');
      lpFile := PChar('regedit.exe');
      nShow := 1;
    end;
    ShellExecuteExA(@ExecInfo);
    WaitForInputIdle(ExecInfo.hProcess, 200);
    hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
  end;
  ShowWindow(hWin, SW_SHOWNORMAL);
  hWin := FindWindowExA(hWin, 0, PChar('SysTreeView32'), nil);
  SetForegroundWindow(hWin);
  i := 30;
  repeat
    SendMessageA(hWin, WM_KEYDOWN, VK_LEFT, 0);
    Dec(i);
  until i = 0;
  Sleep(500);
  SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
  Sleep(500);
  i := 1;
  n := Length(Key);
  repeat
    if Key[i] = '\' then
    begin
      SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
      Sleep(500);
    end
    else
      SendMessageA(hWin, WM_CHAR, Integer(Key[i]), 0);
    i := i + 1;
  until i = n;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  JumpToKey('HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer');
end;

end.

Create a form using Win API only

Problem/Question/Abstract:

How can I create a form without using the Forms unit?

Answer:

program InputAPI;

uses
  Windows, Messages;

var
  WinClass: TWndClassA;
  Inst, Handle, Button1, Button2: Integer;
  Msg: TMsg;
  hFont: Integer;

  { Custom WindowProc function }

function WindowProc(hWnd, uMsg, wParam, lParam: Integer): Integer; stdcall;
begin
  Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
  { Checks for messages }
  if uMsg = WM_DESTROY then
    Halt;
end;

begin
  { Register Custom WndClass }
  Inst := hInstance;
  with WinClass do
  begin
    style := CS_CLASSDC or CS_PARENTDC;
    lpfnWndProc := @WindowProc;
    hInstance := Inst;
    hbrBackground := color_btnface + 1;
    lpszClassname := 'Test';
    hCursor := LoadCursor(0, IDC_ARROW);
  end;
  RegisterClass(WinClass);
  { Create Main Window }
  Handle := CreateWindowEx(WS_EX_WINDOWEDGE or WS_EX_CONTROLPARENT, 'Test',
    'TestWindow', WS_VISIBLE or WS_CAPTION or WS_SYSMENU, 300, 200, 300, 100,
    0, 0, Inst, nil);
  { Create a button }
  Button1 := CreateWindow('Button', 'Ok', WS_VISIBLE or WS_CHILD or WS_TABSTOP or
    BS_PUSHLIKE or BS_TEXT, 50, 20, 75, 25, handle, 0, Inst, nil);
  Button2 := CreateWindow('Button', 'Cancel', WS_VISIBLE or WS_CHILD or WS_TABSTOP or
    BS_PUSHLIKE or BS_TEXT, 150, 20, 75, 25, handle, 0, Inst, nil);
  { Create Font Handle }
  hFont := CreateFont(-15, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS,
    CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or FF_DONTCARE,
    'MS Sans Serif');
  { Change fonts }
  if hFont <> 0 then
  begin
    SendMessage(Button1, WM_SETFONT, hFont, 0);
    SendMessage(Button2, WM_SETFONT, hFont, 0);
  end;
  SetFocus(Button1);
  UpdateWindow(Handle);
  { Message Loop }
  while (GetMessage(Msg, 0, 0, 0)) do
    if not IsDialogMessage(handle, msg) then
    begin
      TranslateMessage(msg);
      DispatchMessage(msg);
    end;
end.

How to assign all property values of one class to another instance of the same class

Problem/Question/Abstract:

How can I assign all property values (or if it&#8217;s not possible only published property values, or some of them) of one class (TComponent) to another instance of the same class? What I want to do is:

MyComponent1. {property1} := MyComponent2. {property1};
{...}
MyComponent2. {propertyN} := MyComponent2. {propertyN};

Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn&#8217;t work. Why not? Can I point to the second component ?

Answer:

Solve 1:

MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values.

A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example:

procedure TMyComponent.Assign(Source: TPersistent);
begin
  if Source is TMyComponent then
  begin
    property1 := TMyComponent(Source).property1;
    { ... }
  end
  else
    inherited Assign(Source);
end;

To assign properties you'll need to set this line in the code:

MyComponent1.Assign(MyComponent2);


Solve 2:

procedure EqualClassProperties(AClass1, AClass2: TObject);
var
  PropList: PPropList;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
  i: integer;
  NumProps: Integer;
  APersistent: TPersistent;
begin
  if AClass1.ClassInfo <> AClass2.ClassInfo then
    exit;
  ClassTypeInfo := AClass1.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  if ClassTypeData.PropCount <> 0 then
  begin
    GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
    try
      GetPropInfos(AClass1.ClassInfo, PropList);
      for i := 0 to ClassTypeData.PropCount - 1 do
        if not (PropList[i]^.PropType^.Kind = tkMethod) then
          {if Class1,2 is TControl/TWinControl on same form, its names must be unique}
          if PropList[i]^.Name <> 'Name' then
            if (PropList[i]^.PropType^.Kind = tkClass) then
            begin
              APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name,
                TPersistent));
              if APersistent <> nil then
                APersistent.Assign(TPersistent(GetObjectProp(AClass2,
                  PropList[i]^.Name, TPersistent)))
            end
            else
              SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2,
                PropList[i]^.Name));
    finally
      FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
    end;
  end;
end;

Note that this code skips object properties inherited other than TPersistent.

Changing Position of Current Played Track in TMediaPlayer

Problem/Question/Abstract:

Difficulties in moving forward/backward (changing position) the current played track in TMediaPlayer ??

Answer:

To change the current position of current playing track, you just need to take the usefull (advance) of two event: 1) onTimer of TTimer and 2) onChange of TScrollbar. For full code, read below.

Here are the codes:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (OpenDialog1.Execute) then
  begin
    Timer1.Enabled := false;
    MediaPlayer1.FileName := OpenDialog1.FileName;
    MediaPlayer1.Open;
    ScrollBar1.Max := MediaPlayer1.Length;
    ScrollBar1.Position := 0;
    Timer1.Enabled := true;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  ScrollBar1.OnChange := nil; // disable the event handler
  ScrollBar1.Position := MediaPlayer1.Position;
  ScrollBar1.OnChange := ScrollBar1Change; // enable it again
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
  MediaPlayer1.Pause;
  MediaPlayer1.Position := ScrollBar1.Position;
  MediaPlayer1.Play;
end;

First thing you must do here is initiate the MAX range of TScrollBar with the length of the current song track (look at Button1Click above).

Then add onTimer event code like above, and so the onChange event of TScrollBar.
The key is you must set TMediaPlayer's position with your selected scroolbar position for each of onTimer happen. Do this by calling onChange event of TScrollBar in onTimer event of TTimer.

Changing the screen resolution

Problem/Question/Abstract:

How can I change the screen resolution?

Answer:

To change the screen resolution you can use the following function which is a wrapper for the Windows API ChangeDisplaySettings. The function takes the desired width and height as parameters and returns
the return value of ChangeDisplaySettings (see the documentation for more datails).

function SetScreenResolution(Width, Height: integer): Longint;
var
  DeviceMode: TDeviceMode;
begin
  with DeviceMode do
  begin
    dmSize := SizeOf(TDeviceMode);
    dmPelsWidth := Width;
    dmPelsHeight := Height;
    dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
  end;
  Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);
end;

You can use ChangeDisplaySettings to change other properties of the display like the color depth and the display frequency.

Sample call

In the following example first we get the current screen resolution before setting it to 800x600, and then we restore it calling SetScreenResolution again.

var
  OldWidth, OldHeight: integer;

procedure TForm1.Button1Click(Sender: TObject);
begin
  OldWidth := GetSystemMetrics(SM_CXSCREEN);
  OldHeight := GetSystemMetrics(SM_CYSCREEN);
  SetScreenResolution(800, 600);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetScreenResolution(OldWidth, OldHeight);
end;

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

How to find a window by its (partial) title and close it (2)

Problem/Question/Abstract:

I am trying to figure out how I can get the handle of the main window of another application so I can terminate that program. I simply need to terminate one application from another application.

Answer:

This Code waits x seconds for a certain window to appear, tries to put it on top and send keystrokes to it. Pay special attention to the FindWindow Command. The Caption is the "EXACT" text in the window title bar. To do a partial match you have to have Windows ENUMERATE all it's open windows, then test the list that comes back.

function TMainForm.WaitForWindowAndType(WindowCaption, TextToSend: string;
  SecondsToWait: Cardinal): boolean;
var
  h: Hwnd;
  i: cardinal;
  vk: word;
begin
  i := SecondsToWait;
  repeat
    Application.ProcessMessages;
    sleep(1000);
    h := FindWindow(nil, pchar(WindowCaption));
    dec(i);
  until
    (i < 1) or (h > 0);
  result := not (h < 1);
  if h < 1 then
  begin
    {do nothing}
  end
  else
  begin
    memo1.Lines.Add(format('Found %s, after %d seconds.', [WindowCaption,
                 SecondsToWait - i]));
    sendmessage(h, WM_ACTIVATE, 0, 0);
    sendmessage(h, WM_SETFOCUS, 0, 0);
    i := 1;
    while integer(i) <= length(TextToSend) do
    begin
      if texttosend[i] = '@' then
      begin
        inc(i);
        vk := VkKeyScan(texttosend[i]);
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0); {this is the ALT key}
        keybd_event(vk, MapVirtualKey(VK, 0), 0, 0); {ALT Letter}
        keybd_event(vk, MapVirtualKey(VK, 0), KEYEVENTF_KEYUP, 0); {Letter UP}
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0); {ALT UP}
      end
      else
      begin
        vk := VkKeyScan(texttosend[i]);
        if vk shr 8 = 1 then
        begin
          keybd_event(VK_SHIFT, 0, 0, 0);
          keybd_event(vk, 0, 0, 0);
          keybd_event(vk, 0, KEYEVENTF_KEYUP, 0);
          keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);
        end
        else
        begin
          keybd_event(vk, 0, 0, 0);
          keybd_event(vk, 0, KEYEVENTF_KEYUP, 0);
        end;
      end;
      sleep(100);
      inc(i);
    end;
  end;
end;

Missing unit 'Proxies.pas'

Problem/Question/Abstract:

If your application or expert uses designtime information, you have to replace
uses DsgnIntf;
with
uses DesignIntf, DesignEditors;
But then you will run into an error message 'Cannot find unit Proxies.pas'

Answer:

The solution is to add DesignIde.dcp to your list of required packages.

You will have to ensure that the run-time package does not require the design-time package(s). This change in Delphi 6 enforces Borland's licence restrictions on designtime editors more strongly, which have been in the license documents since Delphi 3, I believe.

Detect your own IP Address

Problem/Question/Abstract:

Detect your own IP Address

Answer:

uses
  WinSock; // type PHostEnt

function My_IP_Address: longint;
var
  buf: array[0..255] of char;
  RemoteHost: PHostEnt;
begin
  Winsock.GetHostName(@buf, 255);
  RemoteHost := Winsock.GetHostByName(buf);
  if RemoteHost = nil then
    My_IP_Address := winsock.htonl($07000001) { 127.0.0.1 }
  else
    My_IP_Address := longint(pointer(RemoteHost^.h_addr_list^)^);
  Result := Winsock.ntohl(Result);
end;

Extract and display version info from files

Problem/Question/Abstract:

Extract and display version info from files

Answer:

This routine shows how to retrieve version information from the Windows resources and displays it with a ShowMessage box:

procedure TForm1.GetVersionInfo;
const
  n_Info = 10;
  InfoStr: array[1..n_Info] of string =
  ('CompanyName', 'FileDescription', 'FileVersion', 'InternalName',
    'LegalCopyright', 'LegalTradeMarks', 'OriginalFilename',
    'ProductName', 'ProductVersion', 'Comments');
var
  Info: string;
  BuffSize,
    Len, i: Integer;
  Buff: PChar;
  Value: PChar;
begin
  Info := Application.ExeName;
  BuffSize := GetFileVersionInfoSize(PChar(Info), BuffSize);
  if BuffSize > 0 then
  begin
    Buff := AllocMem(BuffSize);
    Memo1.Lines.Add('FileVersionInfoSize=' + IntToStr(BuffSize));
    GetFileVersionInfo(PChar(Info), 0, BuffSize, Buff);
    Info := Info + ':';
    for i := 1 to n_Info do
      if VerQueryValue(Buff, PChar('StringFileInfo\040904E4\' +
        InfoStr[i]), Pointer(Value), Len) then
        Info := Info + #13 + InfoStr[i] + '=' + Value;
    FreeMem(Buff, BuffSize);
    ShowMessage(Info);
  end
  else
    ShowMessage('No FileVersionInfo found');
end;

How to direct all keyboard events to a specific window

Problem/Question/Abstract:

SetCapture directs all mouse events to a specific window. Is there a similar API for the keyboard? Can this be accomplished without using hooks? I want to track what the user presses on the keyboard and mouse and allow or reject the events.

Answer:

Look up TApplication.OnMessage and study the example given, then look at the example below:


procedure TMainForm.AppMessage(var Msg: TMsg; var Handled: Boolean);
const
  BLOCKEDKEYS = [VK_TAB, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_SPACE];
begin
  if (Msg.message = WM_KEYDOWN) then
  begin
    if (Msg.wParam in BLOCKEDKEYS) then
    begin
      Handled := True;
    end;
  end;
end;

How to restore the original volume settings after changing the volume of a wave

Problem/Question/Abstract:

I'm trying to control the left/ right channel volume of a wave. I've checked with WaveOutGetDevCaps that volume and left/ right control is supported. When I try to read the volume with WaveOutGetVolume (using "word (Wave_Mapper)" as the device), I get MMSysErr_NotSupported. I need the original volume setting in order to restore it later. WaveOutSetVolume also returns the same error.

Answer:

The code below worked for me. You will see that it is in message handlers for WaveOutOpen etc. messages. The key might be that you need the handle to an open wave device rather than simply the constant for wave_mapper.


procedure TClockForm.mm_wom_open(var Msg: TMessage);
{This code handles the WaveOutOpen message by writing two buffers of data
to the wave device.  Plus other miscellaneous housekeeping.}
begin
  waveOutGetVolume(hWave_out, @saved_volumes);
  waveOutSetVolume(hWave_out, volumes);
  waveOutPrepareHeader(hWave_out, p_wave_hdr, SizeOf(TWaveHdr));
  waveOutWrite(hWave_out, p_wave_hdr, SizeOf(TWaveHdr));
end;

procedure TClockForm.mm_wom_done(var Msg: TMessage);
{Handle the wave out done message}
begin
  waveOutSetVolume(hWave_out, saved_volumes);
  waveOutReset(hWave_out);
  waveOutClose(hWave_out);
end;

Protecting code the ... dizzy way

Problem/Question/Abstract:

Code crackers do not only use debuggers but also reverse dissassemblers, that allow viewing code in a more readable form.

Crackers set breakpoints (typically on windows calls or messages), and "peek" on the source code before actually single-stepping back.

This is a small example of how to insert VARIABLE dummy code between valid statements, which can make reverse-dissassembling and single-stepping a nightmare.

Answer:

Conditional ASM statements that actually insert dummy code are of this kind:

       JMP here
       DB byte,byte,byte,byte  ; garble data
  here:

so actually the garble data never get executed. One can find a LOT of combinations that actually drive reverse dissassemblers nuts. This include file, when used, includes variable length dummy statements

----- This is the Include file AsmDizzy.inc: ------

{$IFDEF DIZZY4}
{$UNDEF DIZZY1}
{$UNDEF DIZZY2}
{$UNDEF DIZZY3}
{$UNDEF DIZZY4}
{$ENDIF}

{$IFDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
   DB $EB,$06,$55,$44,$55,$03,$a8,$09;
end;
{$DEFINE DIZZY4}
{$ENDIF}
{$ENDIF}

{$IFDEF DIZZY2}
{$IFNDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
   DB $EB,$04,$75,$13,$a2,$14;
end;
{$DEFINE DIZZY3}
{$ENDIF}
{$ENDIF}
{$ENDIF}

{$IFNDEF DIZZY1}
{$IFNDEF DIZZY2}
{$IFNDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
     DB $EB,$04,$55,$03,$a7,$44;
end;
{$DEFINE DIZZY2}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
;

---- End of incude file ----

Having this include file, try putting this code in the event of a button click. The code executes normally, but a lot of VARIABLE garble code is between the statements, some times 4,5 or 6 bytes wide.

procedure TForm1.Button1Click(Sender: TObject);
begin
{$I AsmDizzy.inc}
  ShowMessage('1');
{$I AsmDizzy.inc}
  ShowMessage('2');
{$I AsmDizzy.inc}
  ShowMessage('3');
{$I AsmDizzy.inc}
  ShowMessage('4');
{$I AsmDizzy.inc}
  ShowMessage('1');
end;

This can make singlestepping a nightmare, even with simple statements (ShowMessage) in-between. The .inc file can be enhanced to produce real random code, but this is a task for you to do.

Get the Processor Usage

Problem/Question/Abstract:

How to get the processor usage

Answer:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, CommCtrl, StdCtrls, Menus, WinSpool, ExtCtrls, Buttons, Registry;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Timer1: TTimer;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    started: boolean;
    reg: TRegistry;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  Dummy: array[0..1024] of byte;
begin
  // Stats started by Button1 hit
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_DYN_DATA; // Statistic data is saved under this topic
  { Before starting retrieving statistic data you have to query
    the appropiate key under 'PerfStats\StartStat'. }
  Reg.OpenKey('PerfStats\StartStat', false);
    // Open this key first to start collecting performance data
  Reg.ReadBinaryData('KERNEL\CPUUsage', Dummy, Sizeof(Dummy));
  Reg.CloseKey;
  started := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  CPUU: integer;
begin
  { After starting the collection of statistic data, you can retrieve the
    recent value under the 'PerfStats\StatData' key. This is done by a timer
    event in this example }
  if started then
  begin
    Reg.OpenKey('PerfStats\StatData', false); // Open extension kex for txt files
    Reg.ReadBinaryData('KERNEL\CPUUsage', CPUU, SizeOf(Integer));
    Reg.CloseKey;
    Label1.Caption := IntToStr(CPUU) + '%';
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Dummy: array[0..1024] of byte;
begin
  // Button2 hit stops statistic collection
  { Collecting statistic data is stopped by a query under 'PerfStats/StopStat' }
  Reg.OpenKey('PerfStats\StopStat', false);
    // Open this key first to start collecting performance data
  Reg.ReadBinaryData('KERNEL\CPUUsage', Dummy, SizeOf(Dummy));
  Reg.Free;
  Started := false;
end;

end.

Outlook Automation - Scaning Outlook's Folders

Problem/Question/Abstract:

How I can information from Outlook in my application

Answer:

Sample how to work with Outlook from Delphi application

unit UScanOutlook;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, Outline;
const
  olByValue = 1;
  olByReference = 4;
  olEmbeddedItem = 5;
  olOLE = 6;

  olMailItem = 0;
  olAppointmentItem = 1;
  olContactItem = 2;
  olTaskItem = 3;
  olJournalItem = 4;
  olNoteItem = 5;
  olPostItem = 6;

  olFolderDeletedItems = 3;
  olFolderOutbox = 4;
  olFolderSentMail = 5;
  olFolderInbox = 6;
  olFolderCalendar = 9;
  olFolderContacts = 10;
  olFolderJournal = 11;
  olFolderNotes = 12;
  olFolderTasks = 13;

type
  TForm1 = class(TForm)
    oline_outlook: TOutline;
    Button8: TButton;
    procedure Button8Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    OlApp, NameSpace, root: OleVariant;
  end;

var
  Form1: TForm1;

implementation
uses ComObj;
{$R *.DFM}

procedure TForm1.Button8Click(Sender: TObject);
  procedure scan(ol: TOutline; root: OleVariant; s: string);
  var
    i, j, k: integer;
    bcount, rcount: integer;
    branch, MAPIFolder: olevariant;
    line: string;
  begin
    line := '';
    rcount := root.count;
    for i := 1 to rcount do
    begin
      line := s + root.item[i].name;
      ol.Lines.Add(line);
      branch := root.item[i].folders;
      bcount := branch.count;
      MAPIFolder := Namespace.GetFolderFromId(root.item[i].EntryID,
        root.item[i].StoreID);
      if MAPIFolder.Items.count > 0 then
        for j := 1 to MAPIFolder.Items.count do
          ol.Lines.Add(s + ' ' + MAPIFolder.Items[j].subject);
      if bcount > 0 then
      begin
        scan(ol, branch, s + ' ');
      end;
    end;
  end;
begin
  oline_outlook.Lines.Clear;
  OlApp := CreateOleObject('Outlook.Application');
  Namespace := OlApp.GetNameSpace('MAPI');
  root := Namespace.folders;
  scan(oline_outlook, root, '');
end;

end.

Opening and Closing a CD Tray better

Problem/Question/Abstract:

Opening and Closing a CD Tray?

Answer:

uses
  MMSystem;

// Open CD Tray

{Simple Way:}

mciSendstring('SET CDAUDIO DOOR OPEN WAIT', nil, 0, Self.Handle);

{More complex way:}

function OpenCD(Drive: Char): Boolean;
var
  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWORD;
  S: string;
  DeviceID: Word;
begin
  Result := False;
  S := Drive + ':';
  Flags := MCI_OPEN_TYPE or MCI_OPEN_ELEMENT;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, MCI_OPEN, Flags, Longint(@OpenParm));
  if Res <> 0 then
    Exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
    if Res = 0 then
      Exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, MCI_CLOSE, Flags, Longint(@OpenParm));
  end;
end;

//Close CD Tray

{Simple Way:}

mciSendstring('SET CDAUDIO DOOR CLOSED WAIT', nil, 0, Self.Handle);

{More complex way:}

function CloseCD(Drive: Char): Boolean;
var
  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWORD;
  S: string;
  DeviceID: Word;
begin
  Result := False;
  S := Drive + ':';
  Flags := MCI_OPEN_TYPE or MCI_OPEN_ELEMENT;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, MCI_OPEN, Flags, Longint(@OpenParm));
  if Res <> then
    Exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
    if Res = 0 then
      Exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, MCI_CLOSE, Flags, Longint(@OpenParm));
  end;
end;

Deleting Registry Key from .Reg file

Problem/Question/Abstract:

Deleting Registry Key from .Reg file

Answer:

If you want to import a key but delete another key at the same time, use the syntax in your Reg file:

[-HKEY_CURRENT_USER\Software\Local Applications]

Note the minus sign after the bracket.

Create a TAction and its OnExecute event at runtime

Problem/Question/Abstract:

How to create a TAction and its OnExecute event at runtime

Answer:

{ ... }
type
  TForm1 = class(TForm)
    ActionList1: TActionList;
    procedure FormCreate(Sender: TObject);
  private
    Action1, Action2: TAction;
    procedure Test(Sender: TObject);
  end;

procedure TForm1.Test(Sender: TObject);
begin
  Caption := IntToStr(Actionlist1.ActionCount);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Action1 := TAction.Create(Actionlist1);
  Action1.Actionlist := Actionlist1;
  Action1.OnExecute := Test;
  Form1.OnClick := Action1.OnExecute;
end;