Work with MS Word DisplayAlerts

Problem/Question/Abstract:

I have the following code:

MsWord.DisplayAlerts := wdAlertsNone;
MsWord.ScreenUpdating := False;
WordDoc := MsWord.Documents.Add(Template, False);

When the file referenced by "Template" is already in use by another document, I will still get a "File in use" dialog (which is bad enough as it is only a template. It shouldn't be opened for editing anyway. But Documents.Add does this by default: there is no readonly option). Isn't DisplayAlerts supposed to supress this dialog?

Answer:

You can check the file yourself before passing it off to Word (not tested with Office 11):

{ ... }
uses
  ComObj, ActiveX, Word2000;

type
  TStorageResult = (srNotOpen, srOpen, srNotStorageFile, srFileNotFound,
    srNotOpenButNotWordDocument, srNotOpenButUnsureWordDocument);

function CheckWordDocument(const AWordDocument: WideString): TStorageResult;
var
  vResult: HRESULT;
  vStatStg: TSTATSTG;
  oStorage: IStorage;
begin
  Result := srOpen;
  if FileExists(AWordDocument) then
  begin
    if StgIsStorageFile(PWideChar(AWordDocument)) = S_OK then
      {Must check for S_OK...cannot use Succeeded().}
    begin
      vResult := StgOpenStorage(PWideChar(AWordDocument), nil, STGM_SHARE_EXCLUSIVE
        or STGM_READWRITE, nil, 0, oStorage);
      if Succeeded(vResult) then
      begin
        Result := srNotOpen;
        if oStorage.Stat(vStatStg, 0) = S_OK then
        begin
          if not IsEqualCLSID(CLASS_WordDocument, vStatStg.clsid) then
            Result := srNotOpenButNotWordDocument;
        end
        else
          Result := srNotOpenButUnsureWordDocument;
        oStorage := nil;
      end;
    end
    else
      Result := srNotStorageFile;
  end
  else
    Result := srFileNotFound;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  vStorageResult: TStorageResult;
begin
  vStorageResult := CheckWordDocument('C:\Your.doc');
  case vStorageResult of
    srNotOpen:
      ShowMessage('The document is not open.');
    srOpen:
      ShowMessage('The document is open.');
    srNotStorageFile:
      ShowMessage('The document is not a storage document.');
    srFileNotFound:
      ShowMessage('The document was not found.');
    srNotOpenButNotWordDocument:
      ShowMessage('The document is not open, but it is not a Word document.');
    srNotOpenButUnsureWordDocument:
      ShowMessage('The document is not open, but it does not look like a Word document.');
  end;
end;

BMP's to AVI file for TAnimate

Problem/Question/Abstract:

BMP's to AVI file for TAnimate

Answer:

TAnimate is a rather nice component. However if you don't want to use the built in AVI files and want to create your own AVI files from BMP files, then you may have a problem as there is no tool in Delphi to do this.

While browsing the web for information on AVI file formats I came upon a site www.shrinkwrapvb.com/avihelp/avihelp.htm that is maintained by Ray Mercer. In this tutorial he explains how to manipulate,read and write AVI files. I was particularly interested in "Step 5" in which he shows a utility that takes a list of BMP files that creates an AVI file which can be used by the TAnimate component. The only problem was that the examples are in Visual Basic, thus a conversion to Delphi was required.

I have posted this procedure
CreateAVI(const FileName : string; BMPFileList : TStrings; FramesPerSec : integer = 10);

To keep the text of the example simple and readable I have left out most to the error checking (try except etc.). You can also play with the AVISaveOptions dialog box, but I can only seem to get it to work with "Full Frames Uncompressed" with BMP files. Can anyone shed some light on this ?

Errors you should check for are ..
All files are valid BMP files and are of the same size.
All Blockreads are valid with no read errors.

Ray has a downloadable EXE that works quite nicely, however I am about to write my own utility that incorporates the following ...

Multiline file selection.
Listbox line reordering (drag/drop).
Sort File list
Layout Save and Load .
AVI Preview.

(I have beta version 1.0.0.0 ready, if anyone wants a copy of exe or source code, drop me a mail at mheydon@pgbison.co.za)

For further info on AVI files I recommend you vist Ray's site at http://www.shrinkwrapvb.com/avihelp/avihelp.htm it really is a well written tutorial (even if it is in Visual Basic)

const
  // AVISaveOptions Dialog box flags

  ICMF_CHOOSE_KEYFRAME = 1; // show KeyFrame Every box
  ICMF_CHOOSE_DATARATE = 2; // show DataRate box
  ICMF_CHOOSE_PREVIEW = 4; // allow expanded preview dialog
  ICMF_CHOOSE_ALLCOMPRESSORS = 8; // don't only show those that
  // can handle the input format
  // or input data
  AVIIF_KEYFRAME = 10;

type

  AVI_COMPRESS_OPTIONS = packed record
    fccType: DWORD; // stream type, for consistency
    fccHandler: DWORD; // compressor
    dwKeyFrameEvery: DWORD; // keyframe rate
    dwQuality: DWORD; // compress quality 0-10,000
    dwBytesPerSecond: DWORD; // bytes per second
    dwFlags: DWORD; // flags... see below
    lpFormat: DWORD; // save format
    cbFormat: DWORD;
    lpParms: DWORD; // compressor options
    cbParms: DWORD;
    dwInterleaveEvery: DWORD; // for non-video streams only
  end;

  AVI_STREAM_INFO = packed record
    fccType: DWORD;
    fccHandler: DWORD;
    dwFlags: DWORD;
    dwCaps: DWORD;
    wPriority: word;
    wLanguage: word;
    dwScale: DWORD;
    dwRate: DWORD;
    dwStart: DWORD;
    dwLength: DWORD;
    dwInitialFrames: DWORD;
    dwSuggestedBufferSize: DWORD;
    dwQuality: DWORD;
    dwSampleSize: DWORD;
    rcFrame: TRect;
    dwEditCount: DWORD;
    dwFormatChangeCount: DWORD;
    szName: array[0..63] of char;
  end;

  BITMAPINFOHEADER = packed record
    biSize: DWORD;
    biWidth: DWORD;
    biHeight: DWORD;
    biPlanes: word;
    biBitCount: word;
    biCompression: DWORD;
    biSizeImage: DWORD;
    biXPelsPerMeter: DWORD;
    biYPelsPerMeter: DWORD;
    biClrUsed: DWORD;
    biClrImportant: DWORD;
  end;

  BITMAPFILEHEADER = packed record
    bfType: word; //"magic cookie" - must be "BM"
    bfSize: integer;
    bfReserved1: word;
    bfReserved2: word;
    bfOffBits: integer;
  end;

  // DLL External declarations

function AVISaveOptions(Hwnd: DWORD; uiFlags: DWORD; nStreams: DWORD;
  pPavi: Pointer; plpOptions: Pointer): boolean;
  stdcall; external 'avifil32.dll';

function AVIFileCreateStream(pFile: DWORD; pPavi: Pointer; pSi: Pointer): integer;
  stdcall; external 'avifil32.dll';

function AVIFileOpen(pPfile: Pointer; szFile: PChar; uMode: DWORD;
  clSid: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIMakeCompressedStream(psCompressed: Pointer; psSource: DWORD;
  lpOptions: Pointer; pclsidHandler: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIStreamSetFormat(pAvi: DWORD; lPos: DWORD; lpGormat: Pointer;
  cbFormat: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIStreamWrite(pAvi: DWORD; lStart: DWORD; lSamples: DWORD;
  lBuffer: Pointer; cBuffer: DWORD; dwFlags: DWORD;
  plSampWritten: DWORD; plBytesWritten: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVISaveOptionsFree(nStreams: DWORD; ppOptions: Pointer): integer;
  stdcall; external 'avifil32.dll';

function AVIFileRelease(pFile: DWORD): integer; stdcall; external 'avifil32.dll';

procedure AVIFileInit; stdcall; external 'avifil32.dll';

procedure AVIFileExit; stdcall; external 'avifil32.dll';

function AVIStreamRelease(pAvi: DWORD): integer; stdcall; external 'avifil32.dll';

function mmioStringToFOURCCA(sz: PChar; uFlags: DWORD): integer;
  stdcall; external 'winmm.dll';

// ============================================================================
// Main Function to Create AVI file from BMP file listing
// ============================================================================

procedure CreateAVI(const FileName: string; IList: TStrings;
  FramesPerSec: integer = 10);
var
  Opts: AVI_COMPRESS_OPTIONS;
  pOpts: Pointer;
  pFile, ps, psCompressed: DWORD;
  strhdr: AVI_STREAM_INFO;
  i: integer;
  BFile: file;
  m_Bih: BITMAPINFOHEADER;
  m_Bfh: BITMAPFILEHEADER;
  m_MemBits: packed array of byte;
  m_MemBitMapInfo: packed array of byte;
begin
  DeleteFile(FileName);
  Fillchar(Opts, SizeOf(Opts), 0);
  FillChar(strhdr, SizeOf(strhdr), 0);
  Opts.fccHandler := 541215044; // Full frames Uncompressed
  AVIFileInit;
  pfile := 0;
  pOpts := @Opts;

  if AVIFileOpen(@pFile, PChar(FileName), OF_WRITE or OF_CREATE, 0) = 0 then
  begin
    // Determine Bitmap Properties from file item[0] in list
    AssignFile(BFile, IList[0]);
    Reset(BFile, 1);
    BlockRead(BFile, m_Bfh, SizeOf(m_Bfh));
    BlockRead(BFile, m_Bih, SizeOf(m_Bih));
    SetLength(m_MemBitMapInfo, m_bfh.bfOffBits - 14);
    SetLength(m_MemBits, m_Bih.biSizeImage);
    Seek(BFile, SizeOf(m_Bfh));
    BlockRead(BFile, m_MemBitMapInfo[0], length(m_MemBitMapInfo));
    CloseFile(BFile);

    strhdr.fccType := mmioStringToFOURCCA('vids', 0); // stream type video
    strhdr.fccHandler := 0; // def AVI handler
    strhdr.dwScale := 1;
    strhdr.dwRate := FramesPerSec; // fps 1 to 30
    strhdr.dwSuggestedBufferSize := m_Bih.biSizeImage; // size of 1 frame
    SetRect(strhdr.rcFrame, 0, 0, m_Bih.biWidth, m_Bih.biHeight);

    if AVIFileCreateStream(pFile, @ps, @strhdr) = 0 then
    begin
      // if you want user selection options then call following line
      // (but seems to only like "Full frames Uncompressed option)

      // AVISaveOptions(Application.Handle,
      //                ICMF_CHOOSE_KEYFRAME or ICMF_CHOOSE_DATARATE,
      //                1,@ps,@pOpts);
      // AVISaveOptionsFree(1,@pOpts);

      if AVIMakeCompressedStream(@psCompressed, ps, @opts, 0) = 0 then
      begin
        if AVIStreamSetFormat(psCompressed, 0, @m_memBitmapInfo[0],
          length(m_MemBitMapInfo)) = 0 then
        begin

          for i := 0 to IList.Count - 1 do
          begin
            AssignFile(BFile, IList[i]);
            Reset(BFile, 1);
            Seek(BFile, m_bfh.bfOffBits);
            BlockRead(BFile, m_MemBits[0], m_Bih.biSizeImage);
            Seek(BFile, SizeOf(m_Bfh));
            BlockRead(BFile, m_MemBitMapInfo[0], length(m_MemBitMapInfo));
            CloseFile(BFile);
            if AVIStreamWrite(psCompressed, i, 1, @m_MemBits[0],
              m_Bih.biSizeImage, AVIIF_KEYFRAME, 0, 0) <> 0 then
            begin
              ShowMessage('Error during Write AVI File');
              break;
            end;
          end;
        end;
      end;
    end;

    AVIStreamRelease(ps);
    AVIStreamRelease(psCompressed);
    AVIFileRelease(pFile);
  end;

  AVIFileExit;
  m_MemBitMapInfo := nil;
  m_memBits := nil;
end;

How to put components into a cell on a TDBGrid

Problem/Question/Abstract:

How to put components into a cell on a TDBGrid

Answer:

This article and the accompanying code shows how to put just about any component into a cell on a grid. By component I mean anything from a simple combobox to a more complicated dialog box. The techniques described below to anything that is termed a visual component. If you can put it into a form you can probably put it into a grid.

There are no new ideas here, in fact, the basic technique simply mimics what the DBGrid does internally. The idea is to float a control over the grid. Inside DBGrid is a TDBEdit that moves around the grid. It's that TDBEdit that you key you data into. The rest of the unfocused cells are really just pictures. What you will learn here, is how to float any type of visual control/component around the grid.

1. TDBLookupComboBox:

You need a form with a DBGrid in it. So start an new project and drop a DBGrid into the main form.

Next drop in a TTable and set it's Alias to DBDEMOS, TableName to GRIDDATA.DB and set the Active property to True. Drop in a DataSource and set it's DataSet property to point to Table1. Go back to the grid and point it's DataSource property to DataSource1. The data from GRIDDATA.DB should appear in your grid.

The first control we are going to put into the grid is a TDBLookupComboBox so we need a second table for the lookup. Drop a second TTable into the form. Set it's Alias also to DBDEMOS, TableName to CUSTOMER.DB and Active to True. Drop in a second data source and set its DataSet to Table2.

Now go get a TDBLookupComboBox from the Data Controls pallet and drop it any where on the form, it doesn't matter where since it will usually be invisible or floating over the grid. Set the LookupComboBox's properties as follows.

DataSource: DataSource1
DataField: CustNo
LookupSource: DataSource2
LookupField: CustNo
LookupDisplay: CustNo  {you can change it to Company later but keep it custno for now)

So far it's been nothing but boring point and click. Now let's do some coding.


The first thing you need to do is make sure that DBLookupComboBox you put into the form is invisible when you run the app. So select Form1 into Object Inspector goto the Events tab and double click on the onCreate event. You should now have the shell for the onCreate event displayed on your screen.

procedure TForm1.FormCreate(Sender: TObject);
begin

end;

Set the LookupComboBox's visible property to False as follows.

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
end;

Those of you who are paying attention are probably asking why I didn't just set this in the Object Inspector for the component. Actually, you could have. Personally, I like to initialize properties that change at run time in the code. I set static properties that don't change as the program runs in the object inspector. I think it makes the code easier to read.

Now we to be able to move this control around the grid. Specifically we want it to automatically appear as you either cursor or click into the column labeled DBLookupCombo. This involves defining two events for the grid, OnDrawDataCell and OnColExit. First lets do OnDrawDataCell. Double click on the grid's OnDrawDataCell event in the Object Inspector and fill in the code as follows.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
      DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
      DBLookupCombo1.Width := Rect.Right - Rect.Left;
      { DBLookupCombo1.Height := Rect.Bottom - Rect.Top; }
      DBLookupCombo1.Visible := True;
    end;
  end;
end;

The reasons for the excessive use begin/end will become clear later in the demo. The code is saying that if the State parameter is gdFocused then this particular cell is the one highlighted in the grid. Further if it's the highlighted cell and the cell has the same field name as the lookup combo's datafield then we need to move the LookupCombo over that cell and make it visible. Notice that the position is determined relative to the form not to just the grid. So, for example, the left side of LookupCombo needs to be the offset of the grid ( DBGrid1.Left) into the form plus the offset of the cell into the grid (Rect.Left).

Also notice that the Height of the LookupCombo has been commented out above. The reason is that the LookupCombo has a minimum height. You just can't make it any smaller. That minimum height is larger than the height of the cell. If you un-commented the height line above. Your code would change it and then Delphi would immediately change it right back. It causes an annoying screen flash so don't fight it. Let the LookupCombo be a little larger than the cell. It looks a little funny but it works.

Now just for fun run the program. Correct all you missing semi-colons etc. Once its running try moving the cursor around the grid. Pretty cool, hu? Not! We're only part of the way there. We need to hide the LookupCombo when we leave the column. So define the grid's onColExit. It should look like this:

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false;
end;

This uses the TDBGrids SelectedField property to match up the FieldName associated with the cell with that of the LookupCombo. The code says, "If the cell you are leaving was in the DBLookupCombo column then make it invisible". Now run it again. Was that worth the effort or what?

Now things look right but we're still missing one thing. Try typing a new customer number into one of the LookupCombo. The problem is that the keystrokes are going to the grid, not to the LookupCombo. To fix this we need to define a onKeyPress event for the grid. It goes like this:

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;

This code is saying that if the key pressed is not a tab key (Chr(9)) and the current field in the grid is the LookupCombo then set the focus to the LookupCombo and then pass the keystroke over to the LookupCombo. OK so I had to use a WIN API function. You don't really need to know how it works just that it works.

But let me explain a bit anyway. To make Window's SendMessage function work you must give it the handle of the component you want to send the message to. Use the component's Handle property. Next it wants to know what the message is. In this case it's Window's message WM_CHAR which says I'm sending the LookupCombo a character. Finally, you need to tell it which character, so word(Key). That's a typecast to type word of the events Key parameter. Clear as mud, right? All you really need to know is to replace the DBLookupCombo1 in the call to the name of the component your putting into the grid. If you want more info on SendMessage do a search in Delphi's on-line help.

Now run it again and try typing. It works! Play with it a bit and see how the tab key gets you out of "edit mode" back into "move the cell cursor around mode".

Now go back to the Object Inspector for the DBLookupCombo component and change the LookupDIsplay property to Company. Run it. Imagine the possibilities.


2. TDBComboBox:

I'm not going to discuss installing the second component, a DBComboBox, because I don't really have anything new to say. It's really the same as #1. Here's the incrementally developed code for your review.

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
  DBComboBox1.Visible := False;
end;

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
      DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
      DBLookupCombo1.Width := Rect.Right - Rect.Left;
      DBLookupCombo1.Visible := True;
    end
    else if (Field.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.Left := Rect.Left + DBGrid1.Left;
      DBComboBox1.Top := Rect.Top + DBGrid1.top;
      DBComboBox1.Width := Rect.Right - Rect.Left;
      DBComboBox1.Visible := True;
    end;
  end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false
  else if DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
    DBComboBox1.Visible := false;
end;

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.SetFocus;
      SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;


3. TDBCheckBox:

The DBCheckBox gets even more interesting. In this case it seems appropriate to leave something in the non-focused checkbox cells to indicate that there's a check box there. You can either draw the "stay behind" image of the checkbox or you can blast in a picture of the checkbox. I chose to do the latter. I created two BMP files one that's a picture of the box checked (TRUE.BMP) and one that's a picture of the box unchecked (FALSE.BMP). Put two TImage components on the form called ImageTrue and ImageFalse and attach the BMP files to there respective Picture properties. Oh yes you also need to put a DBCheckbox component on the form. Wire it to the CheckBox field in DataSource1 and set the Color property to clWindow. First edit the onCreate so it reads as follows:

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
  DBCheckBox1.Visible := False;
  DBComboBox1.Visible := False;
  ImageTrue.Visible := False;
  ImageFalse.Visible := False;
end;

Now we need to modify the onDrawDataCell to do something with cells that do not have the focus. Here comes the code.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      {... see above}
    end
    else if (Field.FieldName = DBCheckBox1.DataField) then
    begin
      DBCheckBox1.Left := Rect.Left + DBGrid1.Left + 1;
      DBCheckBox1.Top := Rect.Top + DBGrid1.top + 1;
      DBCheckBox1.Width := Rect.Right - Rect.Left { - 1 };
      DBCheckBox1.Height := Rect.Bottom - Rect.Top { - 1 };
      DBCheckBox1.Visible := True;
    end
    else if (Field.FieldName = DBComboBox1.DataField) then
    begin
      {... see above}
    end;
  end
  else {in this else area draw any stay-behind bitmaps}
  begin
    if (Field.FieldName = DBCheckBox1.DataField) then
    begin
      if TableGridDataCheckBox.AsBoolean then
        DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageTrue.Picture.Bitmap)
      else
        DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageFalse.Picture.Bitmap)
    end;
  end;
end;

It's the very last part we're most interested in. If the state is not gdFocused and the column in CheckBox then this last bit executes. All it does is check the value of the data in the field and if it's true it shows the TRUE.BMP otherwise it shows the FALSE.BMP. I created the bit maps so they are indented so you can tell the difference between a focused and unfocused cell. Make onColExit look like this:

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false
  else if DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField then
    DBCheckBox1.Visible := false
  else if DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
    DBComboBox1.Visible := false;
end;

Edit onKeyPress to:

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField) then
    begin
      DBCheckBox1.SetFocus;
      SendMessage(DBCheckBox1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.SetFocus;
      SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;

Finally, here's the last trick. The caption of the checkbox needs to change as the user checks or unchecks the box. My first thought was to do this in the TDBCheckBox's onChange event, the only problem is that it doesn't have one. So I had to go back to the Windows API and send another message. "SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0)" which returns a 0 if the box is unchecked, otherwise it's checked.

procedure TForm1.DBCheckBox1Click(Sender: TObject);
begin
  if SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0) = 0 then
    DBCheckBox1.Caption := '  ' + 'False'
  else
    DBCheckBox1.Caption := '  ' + 'True'
end;

That's it. Hopefully you learned something. I've tried this technique with dialog boxes. It works and it's simple. Have fun with it. You don't really need to completely understand it as long as you know how to edit the code and replace the above component names with with the name of the component you want to drop into the grid.


4. Enhancements and error correction:

There are 2 stichy points about the Original grid demo. First, once a component in the grid has the focus it takes 2 Tab presses to move to the next grid cell. The other has to do with adding new records.

Problem one - Two Tab Presses Required

A component installed in the grid is actually floating over the top of the grid and not part of the grid it self. So when that component has the focus it takes two tab presses to move to the next cell. The first tab moves from the floating component to the Grid cell underneath and the second to move to the next grid cell. If this behavior bugs you heres how to fix it.

First in the form that contains grid add private variable called WasInFloater of type boolean, like so.

type
  TForm1 = class(TForm)
    {...}
  private
    { Private declarations }
    WasInFloater: Boolean;
    {...}
  end;

Next create an onEnter event for the LookupCombo where WasInFloater is set to true. Then point the onEnter event for each component that goes into the grid at this same single onEnter event.

procedure TForm1.DBLookupCombo1Enter(Sender: TObject);
begin
  WasInFloater := True;
end;

Finally, and here's the tricky part, define the following onKeyUp event for the grid.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (Key in [VK_TAB]) and WasInFloater then
  begin
    SendMessage(DBGrid1.Handle, WM_KeyDown, Key, 0);
    WasInFloater := False;
  end;
end;

What's happening here is that the grid's onKeyUp is sending it self a KeyDown when the focus just switched from one of the floating controls. This solution handles both tab and shift-tab.

Problem two - New record disappears when component gets focus

The second problem is that if you press add record on the navigator in the demo a new record is added but then when you click on one of the components installed in the grid the new record disappears. The reason for this is that there is a strange grid option called dgCancelOnExit which is True by default. Set it to False and the above problem goes away.

Send a VK_BACK keystroke to a TRichEdit

Problem/Question/Abstract:

Send a VK_BACK keystroke to a TRichEdit

Answer:

procedure SendKey(H: Hwnd; Key: char);
var
vKey, ScanCode: Word;
lParam, ConvKey: Longint;
begin
ConvKey := OemKeyScan(Ord(Key));
ScanCode := ConvKey and $000000FF or $FF00;
vKey := Ord(Key);
lParam := LongInt(ScanCode) shl 16 or 1;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
SendMessage(H, WM_CHAR, vKey, lParam);
lParam := lParam or $C0000000;
SendMessage(H, WM_KEYUP, vKey, lParam);
end;

Used like this:

SendKey(Richedit1.Handle, #8);

How to create a Twist / Swirl effect in Delphi

Problem/Question/Abstract:

How to create a Twist / Swirl effect in Delphi

Answer:

Here's an effect I call 'Twist'. It operates on 24-bit bitmaps using scanline. b and tBufr are TBitmaps, declared and instantiated elsewhere. It assumes b has the original bitmap on which to perform the Twist. tBufr is used as a work area. Results are displayed in a TImage. You would use this in a button click something like:


{ ... }
try
  try
    begin
      b := TBitmap.Create;
      tBufr := TBitmap.Create;
      CopyMe(b, Image1.Picture.Graphic); {copy image to b}
      Twist(100);
    end;
  finally
    begin
      b.Free;
      tBufr.Free;
    end;
  end;
except
  raise ESomeErrorWarning.Create('Kaboom!');
end;
{ ... }


Hope this is what you were looking for:


{A procedure to copy a graphic to a bitmap}

procedure TForm1.CopyMe(tobmp: TBitmap; frbmp: TGraphic);
begin
  tobmp.PixelFormat := pf24bit;
  tobmp.Width := frbmp.Width;
  tobmp.Height := frbmp.Height;
  tobmp.Canvas.Draw(0, 0, frbmp);
end;

procedure TForm1.Twist(Amount: integer);
var
  fxmid, fymid: Single;
  txmid, tymid: Single;
  fx, fy: Single;
  tx2, ty2: Single;
  r: Single;
  theta: Single;
  ifx, ify: Integer;
  dx, dy: Single;
  K: integer;
  Offset: Single;
  ty, tx: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue: Integer;
  total_red, total_green: Single;
  total_blue: Single;
  ix, iy: Integer;
  sli, slo: pRGBArray;

  function ArcTan2(xt, yt: Single): Single;
  begin
    if xt = 0 then
      if yt > 0 then
        Result := Pi / 2
      else
        Result := -(Pi / 2)
    else
    begin
      Result := ArcTan(yt / xt);
      if xt < 0 then
        Result := Pi + ArcTan(yt / xt);
    end;
  end;

begin
  Screen.Cursor := crHourGlass;
  CopyMe(tBufr, b);
  K := Amount; {Adjust this for 'amount' of twist}
  Offset := -(Pi / 2);
  dx := b.Width - 1;
  dy := b.Height - 1;
  r := Sqrt(dx * dx + dy * dy);
  tx2 := r;
  ty2 := r;
  txmid := (b.Width - 1) / 2; {Adjust these to move center of rotation}
  tymid := (b.Height - 1) / 2; {Adjust these to move}
  fxmid := (b.Width - 1) / 2;
  fymid := (b.Height - 1) / 2;
  if tx2 >= b.Width then
    tx2 := b.Width - 1;
  if ty2 >= b.Height then
    ty2 := b.Height - 1;
  for ty := 0 to Round(ty2) do
  begin
    for tx := 0 to Round(tx2) do
    begin
      dx := tx - txmid;
      dy := ty - tymid;
      r := Sqrt(dx * dx + dy * dy);
      if r = 0 then
      begin
        fx := 0;
        fy := 0;
      end
      else
      begin
        theta := ArcTan2(dx, dy) - r / K - Offset;
        fx := r * Cos(theta);
        fy := r * Sin(theta);
      end;
      fx := fx + fxmid;
      fy := fy + fymid;
      ify := Trunc(fy);
      ifx := Trunc(fx);
      {Calculate the weights}
      if fy >= 0 then
      begin
        weight_y[1] := fy - ify;
        weight_y[0] := 1 - weight_y[1];
      end
      else
      begin
        weight_y[0] := -(fy - ify);
        weight_y[1] := 1 - weight_y[0];
      end;
      if fx >= 0 then
      begin
        weight_x[1] := fx - ifx;
        weight_x[0] := 1 - weight_x[1];
      end
      else
      begin
        weight_x[0] := -(fx - ifx);
        Weight_x[1] := 1 - weight_x[0];
      end;
      if ifx < 0 then
        ifx := b.Width - 1 - (-ifx mod b.Width)
      else if ifx > b.Width - 1 then
        ifx := ifx mod b.Width;
      if ify < 0 then
        ify := b.Height - 1 - (-ify mod b.Height)
      else if ify > b.Height - 1 then
        ify := ify mod b.Height;
      total_red := 0.0;
      total_green := 0.0;
      total_blue := 0.0;
      for ix := 0 to 1 do
      begin
        for iy := 0 to 1 do
        begin
          if ify + iy < b.Height then
            sli := tBufr.Scanline[ify + iy]
          else
            sli := tBufr.ScanLine[b.Height - ify - iy];
          if ifx + ix < b.Width then
          begin
            new_red := sli[ifx + ix].rgbtRed;
            new_green := sli[ifx + ix].rgbtGreen;
            new_blue := sli[ifx + ix].rgbtBlue;
          end
          else
          begin
            new_red := sli[b.Width - ifx - ix].rgbtRed;
            new_green := sli[b.Width - ifx - ix].rgbtGreen;
            new_blue := sli[b.Width - ifx - ix].rgbtBlue;
          end;
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red + new_red * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue + new_blue * weight;
        end;
      end;
      slo := b.ScanLine[ty];
      slo[tx].rgbtRed := Round(total_red);
      slo[tx].rgbtGreen := Round(total_green);
      slo[tx].rgbtBlue := Round(total_blue);
    end;
  end;
  Image1.Picture.Assign(b);
  Screen.Cursor := crDefault;
end;

Delphi Direct window in Delphi

Problem/Question/Abstract:

Is there a way to prevent the blasted Delphi Direct window from popping up, seemingly at random?

Answer:

Modify the registry:

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Direct\DontShowAgain = "1"

How to get a list of all current users from the BDE

Problem/Question/Abstract:

Is it possible to get a list of all current users from the BDE? If I try to overwrite a file the BDE will tell me who is using it, one at a time. It would be quicker if I could get a complete list.

Answer:

With Paradox, yes:

procedure BDEGetPDXUserList(AList: TStrings);
var
  hCur: hDBICur;
  UDesc: USERDesc;
begin
  AList.Clear;
  Check(DBIOpenUserList(hCur));
  try
    while DBIGetNextRecord(hCur, dbiNOLOCK, @UDesc, nil) <> DBIERR_EOF do
    begin
      AList.Add(StrPas(UDesc.szUserName));
    end;
  finally
    DBICloseCursor(hCur);
  end;
end;

SmartThreadLib example: Using blocking Indy sockets in a thread

Problem/Question/Abstract:

This is an example on how to use the SmartThreadLib. It provides a class called TTCPSmartThread. This thread contains some basic routines to perform TCP communication using blocking sockets.

Answer:

Below are the folling files:

TCPSmartThread.pas   -  The unit
main.pas  -  demo showing how to use it

{ Smart Thread Lib - TCP example
  Copyright (c) 2002 by DelphiFactory Netherlands BV

  What is it:
  Provides an easy way to use Indy blocking TCP socket client.

  Usage:
  Create your TCP client threads as TTCPSmartThreads and manage them
  using the SmartThreadManager global object.

  Download SmartThreadLib at:
  http://www.delphi3000.com/articles/article_3046.asp

  More about blocking sockets and indy:
  http://www.hower.org/Kudzu/Articles/IntroToIndy/
}

unit TCPSmartThread;

interface

uses
  SysUtils, SmartThreadLib, IdTCPClient, IdException;

resourcestring
  STCPTimedOut = 'Time out while waiting for TCP/IP data';

type
  TTCPSmartThread = class(TSmartThread)
  private
    FWaitDelay: Integer; { time slice during waiting (msec) }
    FMaxWaitCount: Integer;
    FTCP: TIdTCPClient;
  protected
    procedure SmartExecute; override;
    procedure TCPExecute; virtual; abstract;

    procedure Connect(const Host: string; const Port: Integer);
    procedure Disconnect;
    procedure WaitFor(const S: string);
    procedure Write(const S: string);
    procedure WaitForAndWrite(const WaitStr, SendStr: string);
    function ReadLn: string;
  end;

implementation

{ TSmartTCP }

procedure TTCPSmartThread.Connect(const Host: string; const Port: Integer);
begin
  // Disconnect if needed
  Disconnect;

  // setup connection info
  FTCP.Host := Host;
  FTCP.Port := Port;

  // Connect
  FTCP.Connect;

  Check;
end;

procedure TTCPSmartThread.Disconnect;
begin
  Check;
  // disconnect if connected
  if FTCP.Connected then
    FTCP.Disconnect;
  Check;
end;

function TTCPSmartThread.ReadLn: string;
{ Reads a string from the connection.
  The string must be terminated by a LF (#10)
}
const
  EndOfLineMarker = #10;
var
  I: Integer;
begin
  I := 0;
  repeat
    // raise exception if we need to stop
    Check;
    // try to read data
    Result := FTCP.ReadLn(EndOfLineMarker, FWaitDelay);
    // increase the try counter
    Inc(I);
    // exit loop after to many tries, or if data found
  until (not FTCP.ReadLnTimedOut) or (I > FMaxWaitCount);
  // raise an exception if the read data timed out
  if FTCP.ReadLnTimedOut then
    raise EIdResponseError.Create('time out');
  // perform check
  Check;
end;

procedure TTCPSmartThread.SmartExecute;
begin
  FWaitDelay := 100;
  FMaxWaitCount := 5000 div FWaitDelay;
  FTCP := TIdTCPClient.Create(nil);
  try
    TCPExecute;
  finally
    FTCP.Free;
  end;
end;

procedure TTCPSmartThread.WaitFor(const S: string);
{ This function returns when the string specified by S
  is read from the TCP connection.
  A timeout exception can be raised.
}
var
  I: Integer;
begin
  I := 0;
  repeat
    // raise exception if we need to stop
    Check;
    // try to read data
    FTCP.ReadLn(S, FWaitDelay);
    // increase number of tries
    Inc(I);
  until (not FTCP.ReadLnTimedOut) or (I > FMaxWaitCount);
  if FTCP.ReadLnTimedOut then
    raise EIdResponseError.Create(STCPTimedOut);
  Check;
end;

procedure TTCPSmartThread.WaitForAndWrite(const WaitStr, SendStr: string);
{ Wait's for a special string and then sends a reply. }
begin
  WaitFor(WaitStr);
  Write(SendStr);
end;

procedure TTCPSmartThread.Write(const S: string);
{ Send a string over the connection }
begin
  Check;
  FTCP.Write(S);
  Check;
end;

end.

{ Using the TTCPSmartThread to retreive the time and date:   }

unit main;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure OnMessage(Sender: TObject; const AMessage: string);
  public
    { Public declarations }
  end;

type
  TTestThread = class(TTCPSmartThread)
  protected
    procedure TCPExecute; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TTestThread }

procedure TTestThread.TCPExecute;
begin
  Connect('132.163.4.101', 13);
  while True do
    Msg(Readln);
  Disconnect;
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  SmartThreadManager.OnMessage := OnMessage;
  TTestThread.Create;
end;

procedure TForm1.OnMessage(Sender: TObject; const AMessage: string);
begin
  Memo1.lines.add(AMessage);
end;

end.

How to save the canvas of a TPaintBox to a *.bmp file

Problem/Question/Abstract:

How to save the canvas of a TPaintBox to a *.bmp file

Answer:

var
  Bitmap: TBitmap;
  Source: TRect;
  Dest: TRect;
begin
  Bitmap := TBitmap.Create;
  try
    with Bitmap do
    begin
      Width := MyPaintBox.Width;
      Height := MyPaintBox.Height;
      Dest := Rect(0, 0, Width, Height);
    end;
    with MyPaintBox do
      Source := Rect(0, 0, Width, Height);
    Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source);
    Bitmap.SaveToFile('MYFILE.BMP');
  finally
    Bitmap.Free;
  end;
end;

How to remove the 'Create new folder' button of a TOpenDialog

Problem/Question/Abstract:

How to remove the 'Create new folder' button of a TOpenDialog

Answer:

Here is how you can remove the 'Create new folder' button on a TOpenDialog. Look at the lines at the bottom this procedure. But note that although the button is no longer present, it's still possible to create a new folder in the dialog, as well as all other kinds of file/ directory manipulation.

{ ... }
type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
  private
    { Private declarations }
    procedure MoveDialog(var Msg: TMessage); message WM_USER;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MoveDialog(var Msg: TMessage);
var
  rec: TRect;
  wh: HWND;
  l, t, r, b: Integer;
begin
  {Center OpenDialog over form}
  if ofOldStyleDialog in OpenDialog1.Options then
    wh := OpenDialog1.Handle
  else
    wh := Windows.GetParent(OpenDialog1.Handle);
  if IsWindow(wh) then
    if GetWindowRect(wh, rec) then
    begin
      l := (Width - (rec.Right - rec.Left)) div 2 + Left;
      t := (Height - (rec.Bottom - rec.Top)) div 2 + Top;
      r := rec.Right - rec.Left;
      b := rec.Bottom - rec.Top;
      MoveWindow(wh, l, t, r, b, True);
    end;
  if not (ofOldStyleDialog in OpenDialog1.Options) then
  begin
    {Remove the 'Create new folder' toolbutton}
    wh := Windows.GetParent(OpenDialog1.Handle);
    wh := FindWindowEx(wh, 0, 'ToolbarWindow32', nil);
    if wh <> 0 then
      SendMessage(wh, TB_DELETEBUTTON, 5, 0); {uses Commctrl}
    {Warning: 5 is the ID-number of the 'Create new folder' toolbutton.
                It may possibly change on different Windows versions.}
  end;
end;

How to prevent a TPaintBox from flickering

Problem/Question/Abstract:

I need a control similar to a gauge, but a bit different, so I thought that I can use a TPaintBox. In the PaintBox.OnPaint method I create a bitmap and at the end of procedure I call PaintBox.Canvas.Draw(0,0,bmp); (the same is used in Delphi's TGauge control). When I need to show a new value I call PaintBox.Refresh. It does work, however it flickers when repainting.

Answer:

First, you should not create a bitmap in the OnPaint event. This event is called every time the paintbox must be updated, not only when it first becomes visible.

To avoid flicker, set the control's style to csOpaque to avoid background painting.

paintbox1.controlstyle := paintbox1.controlstyle + [csopaque];

or don't call Refresh (or repaint, for that matter). Call the procedure that does the actual drawing stuff (for example, PaintBox1.OnPaint(Self)).

Draw checkboxes in a virtual mode TListView

Problem/Question/Abstract:

How do I get CheckBoxes when using a TListView with OwnerData set to true and using an OnData event method?

Answer:

{ ... }
const
  W_64: Word = 64; {Width of thumbnail in ICON view mode}
  H_64: Word = 64; {Height of thumbnail size}
  CheckWidth: Word = 14; {Width of check mark box}
  CheckHeight: Word = 14; {Height of checkmark}
  CheckBiasTop: Word = 2; {This aligns the checkbox to be in centered}
  CheckBiasLeft: Word = 3; {In the row of the list item display}

procedure DrawCheckMark(const ListViewX: TListView; Item: TListItem; Checked:
  Boolean);
var
  TP1, TP2: TPoint;
  XBias, YBias: Integer;
  OldColor: TColor;
  BiasTop, BiasLeft: Integer;
  Rect1: TRect;
begin
  GetCheckBias(XBias, YBias, BiasTop, BiasLeft, ListViewX);
  OldColor := ListViewX.Canvas.Pen.Color;
  TP1 := Item.GetPosition;
  if Checked then
    ListViewX.Canvas.Brush.Color := clBlack;
  Rect1.Left := Item.Left - CheckWidth - BiasLeft + 1 + XBias;
  Rect1.Top := Tp1.Y + BiasTop + 1 + YBias;
  Rect1.Right := Item.Left - BiasLeft - 1 + XBias;
  Rect1.Bottom := Tp1.Y + BiasTop + CheckHeight - 1 + YBias;
  ListViewX.Canvas.FillRect(Rect1);
  if Checked then
    ListViewX.Canvas.Brush.Color := clBlue
  else
    ListViewX.Canvas.Brush.Color := clBlack;
  ListViewX.Canvas.FrameRect(Rect1);
  ListViewX.Canvas.FrameRect(Rect(Rect1.Left - 1, Rect1.Top - 1,
    Rect1.Right + 1, Rect1.Bottom + 1));
  if Checked then
  begin
    ListViewX.Canvas.Pen.Color := clLime;
    TP2.X := Item.Left - BiasLeft - 2 + XBias;
    TP2.Y := Tp1.Y + BiasTop + 2 + YBias;
    ListViewX.Canvas.PenPos := TP2;
    ListViewX.Canvas.LineTo(Item.Left - BiasLeft - (CheckWidth div 2) +
      XBias, Tp1.Y + BiasTop + (CheckHeight - 2) + YBias);
    ListViewX.Canvas.LineTo(Item.Left - BiasLeft - (CheckWidth - 2) + XBias,
      Tp1.Y + BiasTop + (CheckHeight div 2) + YBias);
    TP2.X := Item.Left - BiasLeft - 2 - 1 + XBias;
    TP2.Y := Tp1.Y + BiasTop + 2 + YBias;
    ListViewX.Canvas.PenPos := TP2;
    ListViewX.Canvas.LineTo(Item.Left - BiasLeft - (CheckWidth div 2) - 1 + XBias,
      Tp1.Y + BiasTop + (CheckHeight - 2) + YBias);
    ListViewX.Canvas.LineTo(Item.Left - BiasLeft - (CheckWidth - 2) - 1 + XBias,
      Tp1.Y + BiasTop + (CheckHeight div 2) + YBias);
  end;
  ListViewX.Canvas.Brush.Color := ListViewX.Color;
  ListViewX.Canvas.Pen.Color := OldColor;
end;

procedure GetCheckBias(var XBias, YBias, BiasTop, BiasLeft: Integer;
  const ListView: TListView);
begin
  XBias := 0;
  YBias := 0;
  if ListView.ViewStyle = vsICON then
  begin
    YBias := H_64 - CheckHeight;
    XBias := 0;
  end;
  BiasTop := CheckBiasTop;
  BiasLeft := CheckBiasLeft;
  if ListView.ViewStyle <> vsReport then
  begin
    BiasTop := 0;
    BiasLeft := 0;
  end;
end;

In the OnCustomDrawItem event you would do something like this:

DrawCheckMark(FileListMenu.ListView1, Item, Item.Checked);

Modifying Table Stucture in Access MDB Files With Delphi Without Access with the Microsoft Jet 4.0 ANSI SQL-92 Extensions

Problem/Question/Abstract:

Sometimes it is necessary to modify the features of an Access MDB Field; while this is a common need, it is not very well known that this can be accomplished with minimal effort, and that it is also possible to do it while in runtime, to change e.g. the length of a text field (both reducing and enlarging) without data loss and without having to create a temporary coulumn to store the data, unlike Interbase or BDE based databases.

How do I modify programmatically the fields inside an Access MDB File from Delphi without loosing my datas? (e.g. the length of a string field)

Answer:

Do you ever needed to change thelength of a text field inside a database?
In the near past this caused a lot of work, but Microsoft has given us a chance to modify the whole structure of an MDB database at runtime without using MS ACCESS.

The technology underlying the exposed techniques is the &#8220;MS Jet Engine 4.0 Extensions&#8221;, freely available on the Microsoft website and installed with the ADO Executable (MDAC_TYP.EXE + JET ENGINE).

Unlike BDE-Based Databases and Interbase, you can accomplish the task of resizing a field  in seconds.

For example, if you want to enlarge from 30 to 50 chars the &#8220;Description&#8221; Field of the &#8220;Catalog&#8221; table in an Access 2000 Database, all you need is to instantiate an ADOQuery, point it to the file with the connection property, executing the query after having filled the SQL property (which is a TStringList of course) with this lines:
Alter Table Catalog Alter Column Description Text(50);

You could think that it is not possible to reduce the size&#8230; That&#8217;s not true; you only have to use another query before the first.

The following syntax could be normally admitted by ADO only if no DataLoss is involved, so e.g. if there is no data truncated in the application of a smaller length.

To avoid this problem, simply launch the query this way:

Update Catalog set Description = left(Description, 10)

Alter Table Catalog Alter Column Description Text(10);

This way all the exceeding characters are truncated under your control previously ancd the resizing operation is admitted (of course take care not to destroy precious datas or violating primary keys!!!).

Hook into the WM_WindowPosChanging message

Problem/Question/Abstract:

Is it somehow possible to "check" in the WM_WindowPosChanging message if the window is resized?

Answer:

In this message, Msg.WindowPos^.flags holds the flags which were originally used with the SetWindowPos, etc. functions. The window will change its size if SWP_NOSIZE is not contained in this flags, and either cx or cy are different, compared to Width and Height values of the form:

procedure TForm1.WMWindowPosChanging(var Msg: TWMWindowPosChanging);
begin
if (Msg.WindowPos^.flags and SWP_NOSIZE = 0) and ((Msg.WindowPos^.cx <> Width)
or (Msg.WindowPos^.cy <> Height)) then
Windows.Beep(1000, 20); {sizing}
end;

Work around for bug in RichEdit when using PasteFromClipboard, while PlainText = True

Problem/Question/Abstract:

If you work with a RichEdit and you set the property PlainText to True, then you can get formatted text into your RichEdit when you use:

RichEdit1.PasteFromClipboard;

Because you set PlainText to True, you are not able to "unformat" this text again. A work around for this problem is using the procedure below. (This is a well known bug! On the site of Borland you'll find another - but very complicated - work around at: http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=13345)

Answer:

//----------------------------------------------------------------------
procedure TForm1.EditPasteClick(Sender: TObject);

var
  h: THandle;
  pchP: PChar;
  asS0: ANSIstring;

begin
  ClipBoard.Open;
  try
    h := Clipboard.GetAsHandle(CF_TEXT);
    pchP := GlobalLock(h);
    asS0 := StrPas(pchP);
    GlobalUnlock(h);
  finally
    Clipboard.Close;
  end;
  if Length(asS0) > 0 then
    RichEdit1.SelText := asS0; // Copy in where the cursor / caret is.
end;
//----------------------------------------------------------------------

IDE harddisk serial number

Problem/Question/Abstract:

You can get model name, firmware revision, serial number and other IDE harddisk information.

Answer:

Most FAQ manuals recommend to use GetVolumeInformation for extracting of "harddisk serial number". But it is the volume serial number, not harddisk s/n. It is assigned and changed during formatting of partition. Some companies use cloning tools for installing software on all new computers by copying from the single harddisk to all another. Of course, volume serial numbers for these disks are identical.

Now you can get real serial number of IDE hardisk.
See also my articles:
1204 "IDE harddisk serial number (Part 2)"
1174 "SCSI-2 device serial number"

// Get first IDE harddisk serial number

function GetIdeSerialNumber: SerialNumber;
const
  IDENTIFY_BUFFER_SIZE = 512;
type
  TIDERegs = packed record
    bFeaturesReg: BYTE; // Used for specifying SMART "commands".
    bSectorCountReg: BYTE; // IDE sector count register
    bSectorNumberReg: BYTE; // IDE sector number register
    bCylLowReg: BYTE; // IDE low order cylinder value
    bCylHighReg: BYTE; // IDE high order cylinder value
    bDriveHeadReg: BYTE; // IDE drive/head register
    bCommandReg: BYTE; // Actual IDE command.
    bReserved: BYTE; // reserved for future use.  Must be zero.
  end;
  TSendCmdInParams = packed record
    // Buffer size in bytes
    cBufferSize: DWORD;
    // Structure with drive register values.
    irDriveRegs: TIDERegs;
    // Physical drive number to send command to (0,1,2,3).
    bDriveNumber: BYTE;
    bReserved: array[0..2] of Byte;
    dwReserved: array[0..3] of DWORD;
    bBuffer: array[0..0] of Byte; // Input buffer.
  end;
  TIdSector = packed record
    wGenConfig: Word;
    wNumCyls: Word;
    wReserved: Word;
    wNumHeads: Word;
    wBytesPerTrack: Word;
    wBytesPerSector: Word;
    wSectorsPerTrack: Word;
    wVendorUnique: array[0..2] of Word;
    sSerialNumber: array[0..19] of CHAR;
    wBufferType: Word;
    wBufferSize: Word;
    wECCSize: Word;
    sFirmwareRev: array[0..7] of Char;
    sModelNumber: array[0..39] of Char;
    wMoreVendorUnique: Word;
    wDoubleWordIO: Word;
    wCapabilities: Word;
    wReserved1: Word;
    wPIOTiming: Word;
    wDMATiming: Word;
    wBS: Word;
    wNumCurrentCyls: Word;
    wNumCurrentHeads: Word;
    wNumCurrentSectorsPerTrack: Word;
    ulCurrentSectorCapacity: DWORD;
    wMultSectorStuff: Word;
    ulTotalAddressableSectors: DWORD;
    wSingleWordDMA: Word;
    wMultiWordDMA: Word;
    bReserved: array[0..127] of BYTE;
  end;
  PIdSector = ^TIdSector;
  TDriverStatus = packed record
    // Error code from driver, or 0 if no error.
    bDriverError: Byte;
    // Contents of IDE Error register. Only valid when bDriverError is SMART_IDE_ERROR.
    bIDEStatus: Byte;
    bReserved: array[0..1] of Byte;
    dwReserved: array[0..1] of DWORD;
  end;
  TSendCmdOutParams = packed record
    // Size of bBuffer in bytes
    cBufferSize: DWORD;
    // Driver status structure.
    DriverStatus: TDriverStatus;
    // Buffer of arbitrary length in which to store the data read from the drive.
    bBuffer: array[0..0] of BYTE;
  end;

var
  hDevice: THandle;
  cbBytesReturned: DWORD;
  ptr: PChar;
  SCIP: TSendCmdInParams;
  aIdOutCmd: array[0..(SizeOf(TSendCmdOutParams) + IDENTIFY_BUFFER_SIZE - 1) - 1] of
    Byte;
  IdOutCmd: TSendCmdOutParams absolute aIdOutCmd;

  procedure ChangeByteOrder(var Data; Size: Integer);
  var
    ptr: PChar;
    i: Integer;
    c: Char;
  begin
    ptr := @Data;
    for i := 0 to (Size shr 1) - 1 do
    begin
      c := ptr^;
      ptr^ := (ptr + 1)^;
      (ptr + 1)^ := c;
      Inc(ptr, 2);
    end;
  end;

begin
  Result := ''; // return empty string on error
  if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then // Windows NT, Windows 2000
  begin
    // warning! change name for other drives: ex.: second drive '\\.\PhysicalDrive1\'
    hDevice := CreateFile('\\.\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  end
  else // Version Windows 95 OSR2, Windows 98
    hDevice := CreateFile('\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0);
  if hDevice = INVALID_HANDLE_VALUE then
    Exit;
  try
    FillChar(SCIP, SizeOf(TSendCmdInParams) - 1, #0);
    FillChar(aIdOutCmd, SizeOf(aIdOutCmd), #0);
    cbBytesReturned := 0;
    // Set up data structures for IDENTIFY command.
    with SCIP do
    begin
      cBufferSize := IDENTIFY_BUFFER_SIZE;
      //      bDriveNumber := 0;
      with irDriveRegs do
      begin
        bSectorCountReg := 1;
        bSectorNumberReg := 1;
        //      if Win32Platform=VER_PLATFORM_WIN32_NT then bDriveHeadReg := $A0
        //      else bDriveHeadReg := $A0 or ((bDriveNum and 1) shl 4);
        bDriveHeadReg := $A0;
        bCommandReg := $EC;
      end;
    end;
    if not DeviceIoControl(hDevice, $0007C088, @SCIP, SizeOf(TSendCmdInParams) - 1,
      @aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil) then
      Exit;
  finally
    CloseHandle(hDevice);
  end;
  with PIdSector(@IdOutCmd.bBuffer)^ do
  begin
    ChangeByteOrder(sSerialNumber, SizeOf(sSerialNumber));
    (PChar(@sSerialNumber) + SizeOf(sSerialNumber))^ := #0;
    Result := PChar(@sSerialNumber);
  end;
end;

For more information about S.M.A.R.T. IOCTL see http://www.microsoft.com/hwdev/download/respec/iocltapi.rtf

See also sample SmartApp from MSDN Knowledge Base Windows Development -> Win32 Device Driver Kit ->
SAMPLE: SmartApp.exe Accesses SMART stats in IDE drives

see also http://home.earthlink.net/~akonshin/
IdeInfo.zip - sample delphi application using S.M.A.R.T. Ioctl API
IdeInfo2.zip - sample delphi application using S.M.A.R.T. Ioctl API

Notice:

WinNT/Win2000 - you must have read/WRITE access right to harddisk

Win98
SMARTVSD.VXD must be installed in \windows\system\iosubsys
(Do not forget to reboot after copying)


Component Download: http://home.earthlink.net/~akonshin/files/IdeInfo2.zip

How to simulate a PrintScreen key press

Problem/Question/Abstract:

How can I manually call the "hardcopy" function (PrtScr) or how can I trick it by sending the keycode for PrtScr?

Answer:

procedure SimulateKeystroke(Key: byte; extra: DWORD);
begin
  keybd_event(Key, extra, 0, 0);
  keybd_event(Key, extra, KEYEVENTF_KEYUP, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Capture the entire screen to the clipboard by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  {Capture the active window to the clipboard by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 1);
end;

How to calculate the line length of a TRichEdit

Problem/Question/Abstract:

I want to fill a whole line with the same char in a TRichEdit but I can't figure out how I could retrieve the maximum char number for a line.

Answer:

The number of characters you would be able to fit into a line depends on the font and the character used (unless the font is fixed-pitch). The first order of the day is to find out how much space is available for the line. This you do by asking the control for its formatting rectangle, which is usually a bit smaller than the client area. Then you determine the font to use and measure the character, which gives you a first estimate of the number of characters that may fit. You construct a string of this character of the calculated length and measure it again. It may turn out to be too long since the length also includes intercharacter distance, so you remove characters till it fits.

function MakeLine(re: TRichEdit; ch: Char): string;
var
  cv: TControlCanvas;
  r: TRect;
  max, len: Integer;
begin
  cv := TControlCanvas.Create;
  try
    cv.Control := re;
    cv.Font.Assign(re.SelAttributes);
    re.Perform(EM_GETRECT, 0, lparam(@r));
    max := r.right - r.Left;
    len := max div cv.TextWidth(ch);
    Result := StringOfChar(ch, len);
    while cv.TextWidth(result) > max do
      Delete(result, Length(Result), 1);
  finally
    cv.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  richedit1.SelText := MakeLine(richedit1, '-');
end;

You may want to enhance this to take account of any margin settings in the current paragraph.

How to receive session switch notifications (XP) ?

Problem/Question/Abstract:

How can I receive the WM_WTSSESSION_CHANGE message when a session switch occurs ?

Answer:

Typically, an application does not need to be notified when a session switch occurs. However, if the application needs to be aware when its desktop is current, it can register for session switch notifications. Applications that   access the serial port or another shared resource on the computer should check for this. To register for a notification, use the following function:

function WTSRegisterSessionNotification(
  hWnd: HWND; // Window handle
  dwFlags: DWORD // Flags
  ): Bool; // Return value

The registered HWND receives the message WM_WTSSESSION_CHANGE through its WindowProc function.

In dwFlags you can specify:

NOTIFY_FOR_THIS_SESSION. A window is notified only about the session change events that affect the session to which window belongs.
NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change events.

The action happening on the session can be found in wParam code, which may contain one of the following flags.

  WTS_CONSOLE_CONNECT:        A session was connected to the console session.
  WTS_CONSOLE_DISCONNECT:     A session was disconnected from the console session.
  WTS_REMOTE_CONNECT:         A session was connected to the remote session.
  WTS_REMOTE_DISCONNECT:      A session was disconnected from the remote session.
  WTS_SESSION_LOGON:          A user has logged on to the session.
  WTS_SESSION_LOGOFF:         A user has logged off the session.
  WTS_SESSION_LOCK:           A session has been locked.
  WTS_SESSION_UNLOCK:         A session has been unlocked.
  WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status.

lParam contains the sessionId for the session affected.

When your process no longer requires these notifications or is terminating, it should call the following to unregister its notification.

function WTSUnRegisterSesssionNotification(
  hWnd: HWND // window handle.
  ): Boolean; // Result

The HWND values passed to WTSRegisterSessionNotification are reference counted, so you must call WTSUnRegisterSessionNotification exactly the same  number of times that you call WTSRegisterSessionNotification.

Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT,  WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as well as to release and acquire console specific resources.

{********************************************************************
  Unit Wtsapi
********************************************************************}

unit Wtsapi;

interface

uses
  Windows;

const
  // The WM_WTSSESSION_CHANGE message notifies applications of changes in session state.
  WM_WTSSESSION_CHANGE = $2B1;

  // wParam values:
  WTS_CONSOLE_CONNECT = 1;
  WTS_CONSOLE_DISCONNECT = 2;
  WTS_REMOTE_CONNECT = 3;
  WTS_REMOTE_DISCONNECT = 4;
  WTS_SESSION_LOGON = 5;
  WTS_SESSION_LOGOFF = 6;
  WTS_SESSION_LOCK = 7;
  WTS_SESSION_UNLOCK = 8;
  WTS_SESSION_REMOTE_CONTROL = 9;

  // Only session notifications involving the session attached to by the window
  // identified by the hWnd parameter value are to be received.
  NOTIFY_FOR_THIS_SESSION = 0;
  // All session notifications are to be received.
  NOTIFY_FOR_ALL_SESSIONS = 1;

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
function UnRegisterSessionNotification(Wnd: HWND): Boolean;
function GetCurrentSessionID: Integer;

implementation

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
// The RegisterSessionNotification function registers the specified window
// to receive session change notifications.
// Parameters:
// hWnd: Handle of the window to receive session change notifications.
// dwFlags: Specifies which session notifications are to be received:
// (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS)
type
  TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL;
    stdcall;
var
  hWTSapi32dll: THandle;
  WTSRegisterSessionNotification: TWTSRegisterSessionNotification;
begin
  Result := False;
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
  if (hWTSAPI32DLL > 0) then
  begin
    try
      @WTSRegisterSessionNotification :=
        GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification');
      if Assigned(WTSRegisterSessionNotification) then
      begin
        Result := WTSRegisterSessionNotification(Wnd, dwFlags);
      end;
    finally
      if hWTSAPI32DLL > 0 then
        FreeLibrary(hWTSAPI32DLL);
    end;
  end;
end;

function UnRegisterSessionNotification(Wnd: HWND): Boolean;
// The RegisterSessionNotification function unregisters the specified window
// Parameters:
// hWnd: Handle to the window
type
  TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall;
var
  hWTSapi32dll: THandle;
  WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification;
begin
  Result := False;
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
  if (hWTSAPI32DLL > 0) then
  begin
    try
      @WTSUnRegisterSessionNotification :=
        GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification');
      if Assigned(WTSUnRegisterSessionNotification) then
      begin
        Result := WTSUnRegisterSessionNotification(Wnd);
      end;
    finally
      if hWTSAPI32DLL > 0 then
        FreeLibrary(hWTSAPI32DLL);
    end;
  end;
end;

function GetCurrentSessionID: Integer;
// Getting the session id from the current process
type
  TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL;
    stdcall;
var
  ProcessIdToSessionId: TProcessIdToSessionId;
  hWTSapi32dll: THandle;
  Lib: THandle;
  pSessionId: DWord;
begin
  Result := -1;
  Lib := GetModuleHandle('kernel32');
  if Lib <> 0 then
  begin
    ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId');
    if Assigned(ProcessIdToSessionId) then
    begin
      ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId));
      Result := pSessionId;
    end;
  end;
end;

end.

{********************************************************************
  Example:
********************************************************************}

unit Unit1;

interface

uses
  Windows, Messages, {...}, Wtsapi;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FRegisteredSessionNotification: Boolean;
    procedure AppMessage(var Msg: TMSG; var HAndled: Boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);
var
  strReason: string;
begin
  Handled := False;
  // Check for WM_WTSSESSION_CHANGE message
  if Msg.Message = WM_WTSSESSION_CHANGE then
  begin
    case Msg.wParam of
      WTS_CONSOLE_CONNECT:
        strReason := 'WTS_CONSOLE_CONNECT';
      WTS_CONSOLE_DISCONNECT:
        strReason := 'WTS_CONSOLE_DISCONNECT';
      WTS_REMOTE_CONNECT:
        strReason := 'WTS_REMOTE_CONNECT';
      WTS_REMOTE_DISCONNECT:
        strReason := 'WTS_REMOTE_DISCONNECT';
      WTS_SESSION_LOGON:
        strReason := 'WTS_SESSION_LOGON';
      WTS_SESSION_LOGOFF:
        strReason := 'WTS_SESSION_LOGOFF';
      WTS_SESSION_LOCK:
        strReason := 'WTS_SESSION_LOCK';
      WTS_SESSION_UNLOCK:
        strReason := 'WTS_SESSION_UNLOCK';
      WTS_SESSION_REMOTE_CONTROL:
        begin
          strReason := 'WTS_SESSION_REMOTE_CONTROL';
          // GetSystemMetrics(SM_REMOTECONTROL);
        end;
    else
      strReason := 'WTS_Unknown';
    end;
    // Write strReason to a Memo
    Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam));
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // register the window to receive session change notifications.
  FRegisteredSessionNotification := RegisterSessionNotification(Handle,
    NOTIFY_FOR_THIS_SESSION);
  Application.OnMessage := AppMessage;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // unregister session change notifications.
  if FRegisteredSessionNotification then
    UnRegisterSessionNotification(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // retrieve current session ID
  ShowMessage(Inttostr(GetCurrentSessionID));
end;

How to flip a bitmap (fast)

Problem/Question/Abstract:

How to flip a bitmap (fast)

Answer:

procedure Flip1Click(Sender: TObject);

var
  DummyImage: TImage;
  X, Y: Integer;
  SrcRect, DstRect: TRect;

begin
  //Assumes that Image1 holds the bitmap to be flipped
  X := Image1.Picture.Bitmap.Width;
  Y := Image1.Picture.Bitmap.Height;
  SrcRect := Rect(0, 0, X, Y);
  DstRect := Rect(X, 0, 0, Y); // <===== Mark this !!!
  DummyImage := TImage.Create(Self);
  DummyImage.Picture.Bitmap.Width := X;
  DummyImage.Picture.Bitmap.Height := Y;
  //DummyImage.Canvas.CopyMode := cmSrcCopy
  DummyImage.Picture.Bitmap.Canvas.CopyRect(DstRect, Image1.Picture.Bitmap.Canvas,
    SrcRect);
  // Write it back to the original bitmap
  Image1.Picture.Bitmap.Assign(DummyImage.Picture.Bitmap);
  DummyImage.Free;
end;

Virtual Methods and Polymorphism Part 2

Problem/Question/Abstract:

Smart Linking

Answer:

In Part I we explored the magic of polymorphism and its Object Pascal implementation, the virtual method. We discovered that the indicator of which virtual method to invoke on the instance data is stored in the instance data itself.

In this installment, we conclude our exploration with a discussion of abstract interfaces and how virtual methods can defeat and enhance "smart linking."

Abstract Interfaces

An abstract interface is a class type that contains no implementation and no data - only abstract virtual methods. Abstract interfaces allow you to completely separate the user of the interface from the implementation of the interface.

And I do mean completely separate; with abstract interfaces, you can have an object implemented in a DLL and used by routines in an .EXE, just as if the object were implemented in the .EXE itself. Abstract interfaces can bridge:

conceptual barriers within an application,
logistical barriers between an application and a DLL,
language barriers between applications written in different programming languages, and
address space barriers that separate Win32 processes.

In all cases, the client application uses the interface class just as it would any class it implemented itself.

Let's now take a closer look at how an abstract interface class can bridge the gap between an application and a DLL. (By the way, abstract interfaces are the foundation of OLE programming.)

Importing Objects from DLLs: The Hard Way. If you want an application to use a function in a DLL, you must create a "fake" function declaration that tells the compiler what it needs to know about the parameter list and result type of the function. Instead of a method body, this fake function declaration contains a reference to a DLL and function name. The compiler sees these and knows what code to generate to call the proper address in the DLL at run time.

To have an application use an object that's implemented in a DLL, you could do essentially the same thing, declaring a separate function for each object method in the DLL. As the number of methods in the DLL object increases, however, keeping track of all those functions will become a chore. To make things a little easier to manage, you could set up the DLL to give you (the client application) an array of function pointers that you would use to call any of the DLL functions associated with a particular DLL class type.

You can see where this is headed. A Virtual Method Table is precisely an array of function pointers (we discussed the VMT last month). Why do things the hard way when the compiler can do the dirty work for you?

Importing Objects from DLLs: The Smart Way. The client module (the application) requires a class declaration that will make the compiler "visualize" a VMT that matches the desired DLL's array of function pointers. Enter the abstract interface class. The class contains a hoard of virtual; abstract; method declarations in the same order as the functions in the DLL's array of function pointers. Of course, the abstract method declarations need parameter lists that match the DLL's functions exactly.

Now you can fetch the array of function pointers from the DLL and typecast a pointer to that array into your application's abstract interface class type. (Okay; it actually needs to be a pointer to a pointer to an array of function addresses. The first pointer simulates the object instance, the second pointer simulates the VMT pointer embedded in the instance data, but who's counting?)

With this typecast in place, the compiler will think you have an instance of that class type. When the compiler sees a method call on that typecast pointer, it will generate code to push the parameters on the stack, then look up the nth virtual method address in the "instance's VMT" (the pointer to the function table provided by the DLL), and call that address. Voil?! Your application is using an "object" that lives in a DLL as easily as one of its own classes.

Exporting Objects from DLLs. Now for the flip side. Where does the DLL get that array of function pointers? From the compiler, of course! On the DLL side, create a class type with virtual methods with the same order and parameter lists as defined by the "red-herring" array of function pointers, and implement those methods to perform the tasks of that class. Then implement and export a simple function from the DLL that creates an instance of the DLL's class and returns a pointer to it. Again, Voil?! Your DLL is exporting an object that can be used by any application that can handle pointers to arrays of function addresses. Also known as objects!

Abstract Interfaces Link User and Implementor. Here's the clincher. How do you guarantee that the order and parameter lists of the methods in the application's abstract interface class exactly match the methods implemented in the DLL?

Simple. Declare the DLL class as a descendant of the abstract interface class used by the application, and override all the abstract virtual methods. The abstract interface is shared between the application and the DLL; the implementation is contained entirely within the DLL.

Abstract Interfaces Cross Language Boundaries. This can also be done between modules written in different languages. The Microsoft Component Object Model (COM) is a language-independent specification that allows different programming languages to share objects as just described. At its core, COM is simply a specification for how an array of function pointers should be arranged and used. COM is the foundation of OLE.

Since Delphi's native class type implementation conforms to COM specifications, there is no conversion required for Delphi applications to use COM objects, nor any conversion required for Delphi applications to expose COM objects for other modules to use.

Of course, when dealing with multiple languages, you won't have the luxury of sharing the abstract interface class between the modules. You'll have to translate the abstract interface class into each language, but this is a small price to pay for the ability to share the implementation.

The Delphi IDE is built entirely upon abstract interfaces, allowing the IDE main module to communicate with the editor and debugger kernel DLLs (implemented in BC++), and with the multitude of component design-time tools that live in the component library (CMPLIB32.DCL) and installable expert modules.

Virtuals Defeat Smart Linking

When the Delphi compiler/linker produces an .EXE, the procedures, variables, and static methods that are not referenced by "live" code (code that is actually used) will be left out of the .EXE file. This process is called smart linking, and is a great improvement over normal linkers that merely copy all code into the .EXE regardless of whether it's actually needed. The result of smart linking is a smaller .EXE on disk that requires less memory to run.

Smart Linking Rule for Virtuals. If the type information of a class is touched (for example, by constructing an instance) by live code, all the virtual methods of the class and its ancestors will be linked into the .EXE, regardless of whether the program actually uses the virtual methods.

For the compiler, keeping track of whether an individual procedure is ever used in a program is relatively simple; figuring out whether a virtual method is used requires a great deal more analysis of the descendants and ancestors of the class. It's not impossible to devise a scheme to determine if a particular virtual method is never used in any descendants of a class type, but such a scheme would certainly require a lot more CPU cycles than normal smart linking, and the resulting reduction in code size would rarely be dramatic. For these reasons (lots of work, greatly reduced compile/link speed, and diminishing returns), adding smart linking of virtual methods to the Delphi linker has not been a high priority for Borland.

If your class has a number of utility methods that you don't expect to use all the time, leaving them static will allow the smart linker to omit them from the final .EXE if they are not used by your program.

Note that including virtual methods involves more than just the bytes of code in the method bodies. Anything that a virtual method uses or calls (including static methods) must also be linked into the .EXE, as well as anything those routines use, etc. Through this cascade effect, one method could potentially drag hundreds of other routines into the .EXE, sometimes at a cost of hundreds of thousands of bytes of additional code and data. If most of these support routines are used only by your unused virtual method, you have a lot of deadwood in your .EXE.

The best general strategy to keep unused virtual methods - and their associated deadwood - under control, is to declare virtual methods sparingly. It's easier to promote an existing static method to virtual when a clear need arises, rather than trying to demote virtual methods down to statics at some late stage of your development cycle.

Virtuals Enhance Smart Linking

Smart linking of virtuals is a two-edged sword: What is so often cursed for bloating executables with unused code can also be exploited to greatly reduce the amount of code in an executable in certain circumstances - even beyond what smart linking could normally achieve with ordinary static methods and procedures. The key is to turn the smart linking rule for virtuals inside out:

Inverse Smart Linking Rule for Virtuals. If the type information of a class is not touched by live code, then none of that class' virtual methods will be linked into the executable. Even if those virtual methods are called polymorphically by live code!

In a virtual method call, the compiler emits machine code to grab the VMT pointer from the instance data, and to call an address stored at a particular offset in the VMT. The compiler can't know exactly which method body will be called at run time, so the act of calling a virtual method does not cause the smart linker to pull any method bodies corresponding to that virtual method identifier into the final executable.

The same is true for dynamic methods. The act of constructing an instance of the class is what cues the linker to pull in the virtual methods of that particular class and its ancestors. This saves the program from the painful death that would surely result from calling virtual methods that were not linked into the program. After all, how could you possibly call a virtual method of an object instance defined and implemented in your program if you did not first construct said instance? The answer is: you can't. If you obtained the object instance from some external source, e.g. a DLL, then the virtual methods of that instance are in the DLL, not your program.

So, if you have code that calls virtual methods of a class that is never constructed by routines used in the current project, none of the code associated with those virtual methods will be linked into the final executable.

The code in Figure 1 will cause the linker to pull in all the virtual methods of TKitchenGadget and TOfficeManager, because those classes are constructed in live code (the main program block), and all the virtual methods of TBaseGadget, because it's the ancestor of TKitchenGadget.

type
  TBaseGadget = class
    constructor Create;
    procedure Whirr; virtual; { Linked in: YES }
  end;

  TOfficeGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: NO }
    procedure Buzz; { Linked in: NO }
    procedure Pop; virtual; { Linked in: NO }
  end;

  TKitchenGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: YES }
  end;

  TOfficeManager = class
  private
    FOfficeGadget: TOfficeGadget;
  public
    procedure InstantiateGadget; { Linked in: NO }
    { Linked in: YES }
    procedure Operate(AGadget: TOfficeGadget); virtual;
  end;

  { ... Non-essential code omitted ... }

procedure TOfficeManager.InstantiateGadget;
begin { Dead code, never called }
  FOfficeGadget := TOfficeGadget.Create;
end;

procedure TOfficeManager.Operate(AGadget: TOfficeGadget);
{ Live code, virtual method of a constructed class }
begin
  AGadget.Whirr
end;

var
  X: TBaseGadget;
  M: TOfficeManager;
begin
  X := TKitchenGadget.Create;
  M := TOfficeManager.Create;

  X.Free;
  M.Free;
end.
Figure 1: Inverse virtual smart linking: TOfficeGadget.Whirr will not be linked into this program, although Whirr is touched by the live method TOfficeManager.OperateGadget.

Because TOfficeManager.Operate is virtual, its method body is all live code (even though Operate is never called). Therefore, the call to AGadget.Whirr is a live reference to the virtual method Whirr. However, TOfficeGadget is not constructed in live code in this example -TOfficeManager.InstantiateGadget is never used. Nothing of TOfficeGadget will be linked into this program, even though a live routine contains a call to Whirr through a variable of type TOfficeGadget.

Variations on a Theme. Let's see how the scenario changes with a few slight code modifications. The code in Figure 2 adds a call to AGadget.Buzz in the TOfficeManager.Operate method. Notice that the body of TOfficeGadget.Buzz is now linked in, but TOfficeGadget.Whirr is still not. Buzz is a static method, so any live reference to it will link in the corresponding code, even if the class is never constructed.

type
  TBaseGadget = class
    constructor Create;
    procedure Whirr; virtual; { Linked in: YES }
  end;

  TOfficeGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: NO }
    procedure Buzz; { Linked in: YES }
    procedure Pop; virtual; { Linked in: NO }
  end;

  TKitchenGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: YES }
  end;

  TOfficeManager = class
  private
    FOfficeGadget: TOfficeGadget;
  public
    procedure InstantiateGadget; { Linked in: NO }
    { Linked in: YES }
    procedure Operate(AGadget: TOfficeGadget); virtual;
  end;

  { ... Non-essential code omitted ... }

procedure TOfficeManager.InstantiateGadget;
begin { Dead code, never called }
  FOfficeGadget := TOfficeGadget.Create;
end;

procedure TOfficeManager.Operate(AGadget: TOfficeGadget);
{ Live code, virtual method of a constructed class }
begin
  AGadget.Whirr;
  AGadget.Buzz; { This touches the static method body }
end;
var
  X: TBaseGadget;
  M: TOfficeManager;
begin
  X := TKitchenGadget.Create;
  M := TOfficeManager.Create;

  X.Free;
  M.Free;
end.
Figure 2: Notice how the addition of a call to the static Buzz method affects its linked-in status. TOfficeGadget.Whirr is still not included.

The code in Figure 3 adds a call to the static method TOfficeManager.InstantiateGadget. This brings the construction of the TOfficeGadget class into the live code of the program, which brings in all the virtual methods of TOfficeGadget, including TOfficeGadget.Whirr (which is called by live code) and TOfficeGadget.Pop (which isn't). If you deleted the call to AGadget.Buzz, the TOfficeGadget.Buzz method would become dead code again. Static methods are linked in only if they are used in live code, regardless of whether their class type is used.

type
  TBaseGadget = class
    constructor Create;
    procedure Whirr; virtual; { Linked in: YES }
  end;

  TOfficeGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: YES }
    procedure Buzz; { Linked in: YES }
    procedure Pop; virtual; { Linked in: YES }
  end;

  TKitchenGadget = class(TBaseGadget)
    procedure Whirr; override; { Linked in: YES }
  end;

  TOfficeManager = class
  private
    FOfficeGadget: TOfficeGadget;
  public
    procedure InstantiateGadget; { Linked in: YES }
    { Linked in: YES }
    procedure Operate(AGadget: TOfficeGadget); virtual;

  end;

  { ... Non-essential code omitted ... }

procedure TOfficeManager.InstantiateGadget;
begin { Live code }
  FOfficeGadget := TOfficeGadget.Create;
end;

procedure TOfficeManager.Operate(AGadget: TOfficeGadget);
{ Live code, virtual method of a constructed class }
begin
  AGadget.Whirr;
  AGadget.Buzz; { This touches the static method body }
end;

var
  X: TBaseGadget;
  M: TOfficeManager;
begin
  X := TKitchenGadget.Create;
  M := TOfficeManager.Create;

  M.InstantiateGadget;

  X.Free;
  M.Free;
end.
Figure 3: With a call to InstantiateGadget, the construction of TOfficeGadget becomes live and all of TOfficeGadget's virtual methods are linked.

Life in the Real World. Let's examine a slightly more complex (and more interesting) example of this virtual smart linking technique inside the VCL.

The Delphi streaming system has two parts: TReader and TWriter, which descend from a common ancestor, TFiler:

TReader contains all the code needed to load components from a stream.
TWriter contains everything needed to write components to a stream.

These classes were split because many Delphi applications never need to write components to a stream - most applications only read forms from resource streams at program start up. If the streaming system was implemented in one class, all your applications would wind up carrying around all the stream output code, although many don't need it.

So, splitting the streaming system into two classes improved smart linking. End of story? Not quite.

In a careful examination of the code linked into a typical Delphi application, the Delphi R&D team noticed that bits of TWriter were being linked into the .EXE. This seemed odd, because TWriter was definitely never instantiated in the test program. Some of those TWriter bits touched a lot of other bits that piled up rather quickly into a lot of unused code. Let's backtrack a little to see what lead to this code getting into the .EXE, and its surprising solution.

Delphi's TComponent class defines virtual methods that are responsible for reading and writing the component's state in a stream, using TReader and TWriter classes. Because TComponent is the ancestor of just about everything of importance in Delphi, TComponent is almost always linked into your Delphi programs, along with all the virtual methods of TComponent.

Some of TComponent's virtual methods use TWriter methods to write the component's properties to a stream. Those TWriter methods were static methods.

Therefore, TComponent virtual methods are always included in Delphi form-based applications, and some of those virtual methods (e.g. TComponent.WriteState) call static methods of TWriter (e.g. TWriter.WriteData). Thus, those static method bodies of TWriter were being linked into the .EXE. TWriter.WriteData is the kingpin method that drives the entire stream output system, so when it is linked in, almost all the rest of TWriter tags along (everything, ironically, except TWriter.Create).

The solution to this code bloat (caused indirectly by the TComponent.WriteState virtual method) may throw you for a loop: To eliminate the unneeded TWriter code, make more methods of TWriter (e.g. WriteData) virtual!

The all-or-none clumping of virtual methods that we curse for working against the smart linker can be used to our advantage, so that TWriter methods that must be called by live code are not actually included unless TWriter itself is instantiated in the program. Because methods such as TWriter.WriteData are always used when you use a TWriter, and TWriter is a mule class (no descendants), there is no appreciable cost to making TWriter.WriteData virtual.

The benefits, however, are appreciable: Making TWriter.WriteData virtual shaved nearly 10KB off the size of a typical Delphi 2 .EXE. Thanks to this and other code trimming tricks, Delphi 2 packs more standard features (e.g. form inheritance and form linking) into smaller .EXEs than Delphi 1.

What's Really in Your Executables? The simplest way to find out if a particular routine is linked into a particular project is to set a breakpoint in the body of that routine and run the program in the debugger. If the routine is not linked into the .EXE, the debugger will complain that you have set an invalid breakpoint.

To get a complete picture of what's in your .EXE or DLL, configure the linker options to emit a detailed map file. From Delphi's main menu, select Project | Options to display the Project Options dialog box. Select the Linker tab. In the Map File group box, select Detailed. Now recompile your project. The map file will contain a list of the names of all the routines (from units compiled with $D + debug information) that were linked into the .EXE.

Because the 32-bit Delphi Compiled Unit (.DCU) file has none of the capacity limitations associated with earlier, 16-bit versions of the Borland Pascal product line, there is little reason to ever turn off debug symbol information storage in the .DCU. Leave the $D, $L, and $Y compiler switches enabled at all times so the information is available when you need it in the integrated debugger, map file, or object browser. (If hard disk space is a problem, collect the loose change beneath the cushions of your sofa and buy a new 1GB hard drive.)

Novelty of Inverse Virtual Smart Linking. This technique of using virtual methods to improve smart linking is not unique to Delphi, but because Delphi's smart linker has a much finer granularity than other compiler products, this technique is much more effective in Delphi than in other products.

Most compilers produce intermediate code and limited symbol information in an .OBJ format, and most linkers' atom of granularity for smart linking is the .OBJ file. If you touch something inside a library of routines stored in one .OBJ module, the entire .OBJ module is linked into the .EXE. Thus, C and C++ libraries are often broken into swarms of little .OBJ modules in the hope of minimizing dead code in the .EXE.

Delphi's linker granularity is much finer - down to individual variables, procedures, and classes. If you touch one routine in a Delphi unit that contains lots of routines, only the thing you touch (and whatever it uses) is linked into the .EXE. Thus, there is no penalty for creating large libraries of topically-related routines in one Delphi unit. What you don't use will be left out of the .EXE.

Developing clever techniques to avoid touching individual routines or classes is generally more rewarding in Delphi than in most other compiled languages. In other products, the routines you so carefully avoided will probably be linked into the .EXE anyway because you are still using one of the other routines in the same module. Measuring with a micrometer is futile when your only cutting tool is a chainsaw.

Conclusion

Virtual methods are often maligned for bloating applications with unnecessary code. While it's true that virtuals can drag in code that your application doesn't need, this series has shown that careful and controlled use of virtual methods can achieve greater smart linking efficiency than would be possible with static methods alone.

A Trackbar like on the desktop volume control

Problem/Question/Abstract:

Has it ever bothered you that the TTrackbar in Delphi doesn't look the way you expect?

Answer:

Solve 1:

The TTrackBar in Delphi is very wide. This is unlike the trackbar you see used throughout the Windows 9X and 2000 desktops. For some reason I found this annoying.

After doing some research and a bit of experimenting I discovered the reason. When Delphi creates the trackbar from the windows common controls store it specifies a style of TBS_ENABLESELRANGE (see TTrackBar.CreateParams in ComCtrls.pas). The TBS_ENABLESELRANGE style is what allows the Trackbar to display a selection range and support the three properties SelEnd, SelRange and SelStart..

This range feature is nice but under normal usage isn&#8217;t used much. In most cases all we want is a slider that we can set a min an max value and then set and track the current position (like the desktop volume control).

Anyway, it turns out that if the trackbar is created without this TBS_ENABLESELRANGE style set, then it&#8217;s thickness reverts back to the skinny slider seen on the desktop. See the complete code below for ToaTrackbar.

The new ToaTrackBar is very simple. It just adds a boolean SelRange property which specifies if you want to use the range features of the component. This property defaults to true so it is exactly like the current TTrackBar component. If you can live without the range feature then you can set SelRange to false which has a visible slimming effect. In the code, setting SelRange to false simply recreates the control without the TBS_ENABLESELRANGE style.

To Use - Once you&#8217;ve installed the component code below into your IDE then go to the Samples tab on the component palette find the oaTrackBar and drop it on a form. Now set the new SelRange property to false, TickMarks to tmBoth and TickStyle to tsNone and presto, you have a trackbar just like the desktops volume control.

unit oaTrackBar;
{ Freeware by Alec Bergamini O&A Productions www.o2a.com
  Setting the SelRange to false, TickMarks to tmBoth and TickStyle
  tsNone gives you the same look as the desktop volume slider.}
interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ComCtrls, CommCtrl;

type
  ToaTrackBar = class(TTrackBar)
  private
    fSelRange: Boolean;
    procedure SetSelRange(const Value: Boolean);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property SelRange: Boolean read fSelRange write SetSelRange default True;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [ToaTrackBar]);
end;

{ ToaTrackBar }

constructor ToaTrackBar.Create(AOwner: TComponent);
begin
  inherited;
  fSelRange := True;
end;

procedure ToaTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do
  begin
    if not fSelRange then
      Style := Style and not TBS_ENABLESELRANGE;
  end;
end;

procedure ToaTrackBar.SetSelRange(const Value: Boolean);
begin
  if Value <> fSelRange then
  begin
    fSelRange := Value;
    RecreateWnd;
  end;
end;

end.


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  h1: integer;
begin
  h1 := getwindowlong(trackbar1.handle, GWL_STYLE);
  h1 := h1 xor $20 {numeric value of TBS_ENABLESELRANGE};
  setwindowlong(trackbar1.handle, GWL_STYLE, h1);
end;