Writing wave files to disk

Problem/Question/Abstract:

How do i write a wave file?

Answer:

type
  TPCMWaveHeader = record
    rID: array[0..3] of char; { 'RIFF' Identifier }
    rLen: longint;
    wID: array[0..3] of char; { 'WAVE' Identifier }
    fId: array[0..3] of char; { 'fmt ' Identifier }
    fLen: longint; { Fixed, must be 16 }
    wFormatTag: word; { Fixed, must be 1 }
    nChannels: word; { Mono=1, Stereo=2 }
    nSamplesPerSec: longint; { SampleRate in Hertz }
    nAvgBytesPerSec: longint;
    nBlockAlign: word;
    nBitsPerSample: word; { Resolution, e.g. 8 or 16 }
    dId: array[0..3] of char; { 'data' Identifier }
    dLen: longint; { Number of following data bytes }
  end;

procedure WritePCMWaveFile(Filename: string; Resolution, Channels, Samplerate,
  Samples: integer; Data: Pointer);
var
  h: TPCMWaveHeader;
  f: file;
  databytes: integer;
begin
  DataBytes := Samples;
  DataBytes := DataBytes * Channels; { double if stereo }
  DataBytes := DataBytes * (Resolution div 8); { double if 16 Bit }

  FillChar(h, SizeOf(TPCMWaveHeader), #0);
  with h do
  begin
    rID[0] := 'R';
    rID[1] := 'I';
    rID[2] := 'F';
    rID[3] := 'F'; { 1st identifier }
    rLen := DataBytes + 36;
    wID[0] := 'W';
    wID[1] := 'A';
    wID[2] := 'V';
    wID[3] := 'E'; { 2nd identifier }
    fId[0] := 'f';
    fId[1] := 'm';
    fId[2] := 't';
    fID[3] := Chr($20); { 3rdidentifier ends with a space character }
    fLen := $10; { Fixed, must be 16 }
    wFormatTag := 1; { Fixed, must be 1 }
    nChannels := Channels; { Channels }
    nSamplesPerSec := SampleRate; { Sample rate in Hertz }
    nAvgBytesPerSec := SampleRate * Channels * trunc(Resolution div 8);
    nBlockAlign := Channels * (Resolution div 8); { Byte order, see below }
    nBitsPerSample := Resolution;
    dId[0] := 'd';
    dId[1] := 'a';
    dId[2] := 't';
    dId[3] := 'a'; { Data identifier }
    dLen := DataBytes; { number of following data bytes }
  end;
  AssignFile(f, filename);
  ReWrite(f, 1);
  BlockWrite(f, h, SizeOf(h));
  BlockWrite(f, pbytearray(data), databytes);
  CloseFile(f);
  { The rest of the file is the wave data. Order is low-high for left channel,
      low-high for right channel, and so on.
      For mono or 8 bit files make the respective changes. }
end;

How to retrieve the version stamp of a file

Problem/Question/Abstract:

How do you retrieve the version stamp of a file? I'm getting real tired of setting versions in the Delphi Project | Options dialog box and then defining a (redundant) constant for use in my Help | About boxes !

Answer:

Solve 1:

procedure TfrmSplash.GetBuildInfo(var v1, v2, v3, v4: Word);
var
  VerInfoSize: DWord;
  VerInfo: Pointer;
  VerValueSize: DWord;
  VerValue: PVSFixedFileInfo;
  Dummy: DWord;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), dummy);
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(Application.ExeName), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do
  begin
    v1 := dwFileVersionMS shr 16;
    v2 := dwFileVersionMS and $FFFF;
    v3 := dwFileVersionLS shr 16;
    v4 := dwFileVersionLS and $FFFF;
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

function TfrmSplash.GetBuildInfoString: string;
var
  v1, v2, v3, v4: Word;
begin
  GetBuildInfo(v1, v2, v3, v4);
  Result := Format('%d.%d.%d  (Build %d)', [v1, v2, v3, v4]);
end;


Solve 2:

This function should do it.

uses
  Windows, SysUtils, { ... };

function GetFileVersion(const Filename: string): string;
var
  VerInfSize, Sz: Cardinal;
  VerInfo: Pointer;
  FxFileInfo: PVSFixedFileInfo;

  function MSLSToString(MS, LS: DWORD): string;
  begin
    Result := Format('%d.%d.%d.%d', [MS shr 16, MS and $FFFF, LS shr 16, LS and
      $FFFF]);
  end;

begin
  Result := '';
  if FileExists(Filename) then
  begin
    VerInfSize := GetFileVersionInfoSize(PCHAR(Filename), Sz);
    if VerInfSize > 0 then
    begin
      VerInfo := Allocmem(VerInfSize);
      try
        GetFileVersionInfo(PCHAR(Filename), 0, VerInfSize, VerInfo);
        VerQueryValue(VerInfo, '\\', POINTER(FxFileInfo), Sz);
        if Sz > 0 then
          Result := MSLSToString(FxFileInfo^.dwFileVersionMS,
            FxFileInfo^.dwFileVersionLS);
      finally
        FreeMem(VerInfo);
      end;
    end;
  end;
end;


Solve 3:

type
  TFileVersionInfo = record
    fCompanyName,
      fFileDescription,
      fFileVersion,
      fInternalName,
      fLegalCopyRight,
      fLegalTradeMark,
      fOriginalFileName,
      fProductName,
      fProductVersion,
      fComments: string;
  end;

var
  FileVersionInfo: TFileVersionInfo

procedure GetAllFileVersionInfo(FileName: string);
{ proc to get all version info from a file. }
var
  Buf: PChar;
  fInfoSize: DWord;

  procedure InitVersion;
  var
    FileNamePtr: PChar;
  begin
    with FileVersionInfo do
    begin
      FileNamePtr := PChar(FileName);
      fInfoSize := GetFileVersionInfoSize(FileNamePtr, fInfoSize);
      if fInfoSize > 0 then
      begin
        ReAllocMem(Buf, fInfoSize);
        GetFileVersionInfo(FileNamePtr, 0, fInfoSize, Buf);
      end;
    end;
  end;

  function GetVersion(What: string): string;
  var
    tmpVersion: string;
    Len: Dword;
    Value: PChar;
  begin
    Result := 'Not defined';
    if fInfoSize > 0 then
    begin
      SetLength(tmpVersion, 200);
      Value := @tmpVersion;
      { If you are not using an English OS, then replace the language and
                        codepage identifier with the correct one. English (U.S.) is 0409 (language)
                        and 04E4 (codepage). See CodePage Identifiers and Language Identifiers in
                        the Win32 help file for info. }
      if VerQueryValue(Buf, PChar('StringFileInfo\040904E4\' + What), Pointer(Value),
        Len) then
        Result := Value;
    end;
  end;

begin
  Buf := nil;
  with FileVersionInfo do
  begin
    InitVersion;
    fCompanyName := GetVersion('CompanyName');
    fFileDescription := GetVersion('FileDescription');
    fFileVersion := GetVersion('FileVersion');
    fInternalName := GetVersion('InternalName');
    fLegalCopyRight := GetVersion('LegalCopyRight');
    fLegalTradeMark := GetVersion('LegalTradeMark');
    fOriginalFileName := GetVersion('OriginalFileName');
    fProductName := GetVersion('ProductName');
    fProductVersion := GetVersion('ProductVersion');
    fComments := GetVersion('Comments');
  end;
  if Buf <> nil then
    FreeMem(Buf);
end;

To use it just call it like

GetAllFileVersionInfo(ParamStr(0));


Solve 4:

Call GetVersionDetails and specify the filename.

{ ... }

type
  pTransArrar = ^TTransArrar;
  TTransArrar = record
    wLanugageID: Word;
    wCharacterSet: Word;
  end;

function DecodeTranslationInfo(Buffer: TTransArrar): string;
begin
  Result := IntToHex(Buffer.wLanugageID, 4) + IntToHex(Buffer.wCharacterSet, 4);
end;

function GetVersionDetails(Filename: string; const LookupString: string =
  'FileVersion'): string;
var
  ID: DWord;
  iStructSize: DWord;
  p: PChar;
  pbuf: Pointer;
  plen: DWord;
  ResponseString: string;
begin
  {get the size of the fileinfo structure}
  iStructSize := GetFileVersionInfoSize(PChar(Filename), ID);
  {allocate memory to hold file info data structure}
  p := stralloc(iStructSize);
  {retrieve file version details}
  ResponseString := '';
  if GetFileVersionInfo(PChar(Filename), 0, istructSize, p) then
  begin
    if VerQueryValue(p, pchar('\VarFileInfo\Translation'), pbuf, plen) then
    begin
      if VerQueryValue(p, pchar('\StringFileInfo\' +
        DecodeTranslationInfo(pTransArrar(pbuf)^)
        + '\' + LookupString), pbuf, plen) then
        ResponseString := PChar(pbuf);
    end;
  end;
  strdispose(p);
  Result := ResponseString;
end;


Solve 5:

This functions returns the version as a string.

function GetFileVersion(FileName: string): string;
var
  ResourceSize: Integer;
  ResourceBuffer: PChar;
  GetData: Boolean;
  Ignore: THandle;
  InfoPtr: Pointer;
  VerSize: Cardinal;
  FileInfo: VS_FIXEDFILEINFO;
  Major, Minor, Rleas, Build, Hex: string;
begin
  ResourceSize := GetFileVersionInfoSize(PChar(FileName), Ignore);
  if ResourceSize > 0 then
  begin
    {You need to allocate the ResourceBuffer before you can fillchar it}
    GetMem(ResourceBuffer, ResourceSize);
    GetData := GetFileVersionInfo(PChar(FileName), Ignore, ResourceSize,
      ResourceBuffer);
    if GetData then
    begin
      GetData := VerQueryValue(ResourceBuffer, '\', InfoPtr, VerSize);
      if GetData then
      begin
        Move(InfoPtr^, FileInfo, sizeof(VS_FIXEDFILEINFO));
        Hex := IntToHex(FileInfo.dwFileVersionMS, 8) +
          IntToHex(FileInfo.dwFileVersionLS, 8);
        Major := '$' + Copy(Hex, 1, 4);
        Minor := '$' + Copy(Hex, 5, 4);
        Rleas := '$' + Copy(Hex, 9, 4);
        Build := '$' + Copy(Hex, 13, 4);
        Result := IntToStr(StrToInt(Major)) + '.' + IntToStr(StrToInt(Minor)) + '.'
          + IntToStr(StrToInt(Rleas)) + '.' + IntToStr(StrToInt(Build));
      end
      else
      begin
        Result := '';
      end;
    end
    else
    begin
      Result := '';
    end;
    {need this because you allocated it up above}
    FreeMem(ResourceBuffer);
  end
  else
  begin
    Result := '';
  end;
end;

Runtime errors during loading of an application

Problem/Question/Abstract:

A short detective story of strange runtime errors in Delphi

Answer:

The Crime

&#8220;It was a nice day when if happened. Everything worked fine. I just had to replace one 3rd-party component. Everything compiled with the new version. The problem started when I tried to run the application with the new components. When the application started, it shot-out a fatal runtime error 217, no matter what I did. Compiling the application with or without runtime packages had no affect, nor did including or excluding debug info. Whatever I did, I got the same message.&#8221;

The Plot Thickens

The first thing I did was to check what is runtime error 217. Guess what &#8211; in Delphi help, it is written &#8220;EControlC is the exception class for Ctrl+C key presses in console applications.&#8221;
Well, this explanation does not provide any help, for a number of reasons:

The application is not a console application, but a GUI application.
Who the hell did press Ctrl+C ???

The investigation

First, I tried to place a break point in the dpr file.

The code is:

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.CreateForm(TdmReoprtObj, dmReoprtObj);
  Application.Run;
end.

When I placed the break point on the &#8220;Begin&#8221; line, the application reached that line.
When I placed the break point on the next line &#8211; &#8220;Application.Initialize&#8221;, the application did not reach that line.

Second, I tried to compile the application without runtime packages, with the hope that Delphi will point me to the offensive code, like Delphi does most of the time. This time was one of those times Delphi decided not to help. I had to find the problem my self.

Third, after some consultations, we (I and other code &#8216;detectives&#8217;) decided to go to broth force. We paced breakpoints everywhere - In the start of every initialization section in any unit. Here we found the problem.

When I replaced the 3rd-party component, the new version added a new class to the game, lets call it TOffecsiveClass. The 3rd-party component also registered the class:

RegisterClasses([TOffecsiveClass]);

In my code, we had another class, named also TOffecsiveClass, that was registered using the same function.
The result was that we registered the same class twice, there for getting an exception in the initialization section of a unit.

Conclusion

Runtime error 217 is not a Ctrl+C console application error.
If you have an exception in the initialization or finalization sections of a unit, don&#8217;t expect to get a nice message. Most likely, you&#8217;ll get a runtime error (216 or 217).
If you get runtime errors during the loading of the application, or during the shutdown of it, check the initialization and finalization sections.

How to select a sound card for the TMediaPlayer when two sound cards are installed

Problem/Question/Abstract:

How to select a sound card for the TMediaPlayer when two sound cards are installed

Answer:

procedure send(name: string; out: integer; );
var
  lpset: MCI_WAVE_SET_PARMS;
begin
  with MediaPlayer1 do
  begin
    try
      filename := name;
      Open;
      lpset.wOutput := out; {number of the sound card. zero through number of outputs-1}
      mciSendCommand(DeviceID, MCI_SET, MCI_WAVE_OUTPUT, longint(@lpset));
      Play;
    except
      on EMCIDeviceError do
        statusbar := '[OUTPUT FAILED]:' + IntToStr(out);
    else
      ShowMessage(Exception(ExceptObject).Message);
    end;
  end;
end;


Note that for MIDI files the right command to pass to MCI is related to the sequencer port, not to the wave port, so the following adjustments have to be made:


var
  lpset: MCI_SEQ_SET_PARMS;

  {number of the sound card. zero thru number of outputs-1}
  lpset.dwPort := mydeviceid;
  mciSendCommand(DeviceID, MCI_SET, MCI_SEQ_SET_PORT, longint(@lpset));

Something missing about packages

Problem/Question/Abstract:

Packages are a great feature of Delphi. You can put not only components into packages but also everything you want. This way you can build modular, customizable applications.
Many programmers do not use packages because they modify VCL units and they do not have VCL packages source code in order to rebuild them.

Answer:

Introduction

Packages are a great feature of Delphi. You can put not only components into packages but also everything you want. This way you can build modular, customizable applications.
Many programmers do not use packages because they modify VCL units and they do not have VCL packages source code in order to rebuild them.
In this article you will find instructions for using packages anytime, anywhere.

How do packages work

By default, when you compile your project every VCL unit required by your project is compiled into the generated .EXE file. This way a simple Delphi project has at least 300 KB. If you modify one line of one unit then you need to recompile the entire project. These kinds of applications are difficult to modularize. If you have more than one application running on the same computer then you are consuming more RAM than you need.
If you select Project | Options and go to the Packages tab you can instruct Delphi to use Runtime packages.
This way the .EXE file size decrease because the VCL units are not compiled into it. Using runtime packages VCL units are kept into VCL packages and you need to distribute them with your .EXE file. VCL packages have the .BPL extension and they are a special kind of dynamic link libraries (DLL). Delphi installs .BPL files in Windows\System32 directory.
When you use runtime packages Delphi uses .DCP files to build the .EXE file. These .DCP files are to .DPK files (packages source code) what .DCU files are to .PAS files. When you build a package Delphi puts all the .DCU files into a single .DCP file. Then, when you compile a project that uses runtime packages Delphi uses the .DCP files instead of .PAS or .DCU files. So, what happened if you modify, for example, ActnList.pas. If you want to use runtime packages then you need to rebuild VCL package, which includes this unit. And because VCL package is required by almost all the other VCL packages, then you need to rebuild them all.

How can you rebuild all the VCL packages?

Delphi includes a package for user components. The name of this package is dlcusr.dpk and it is located in the Delphi\Lib directory. Open it. In the package editor you can see the Contains and Requires clauses. Select the Requires clause and if there is not any package do the following:

Click the Add button.
Type vcl.dcp in the package name edit control in the Add dialog box
Click the OK button.

Now select the vcl.dcp package or any other VCL package and right click on it. From the popup menu select Open.
The VCL package is generated and now you can build it. Because this is a generated package you need to save it with a different name. Now you can build your project using the new generated package.

Your own VCL packages

Delphi packages were built according to Delphi needs. Your application's needs could be different. Maybe you need different packages. VCL.BPL is a big file (1.3 MB or so). With this trick now you know in which package each unit lives. So you can create your own VCL packages containing only the VCL units your project use.

Determine if a file is in use

Problem/Question/Abstract:

I want to do some manipulation in a file and was wondering if there was a function, say IsFileInUse(filename), which will return true if another application/ process is accessing the file at that moment. I need to be able to delete the file and exchange it with another one.

Answer:

Solve 1:

function IsFileInUse(path: string): Boolean;
var
  f: file;
  r: integer;
begin
  r := -1;
  system.AssignFile(f, path);
{$I-}
  reset(f);
{$I+}
  r := ioresult; {sm(ns(r));}
  {5 = access denied}
  if (r = 32) or (r = 5) then
    result := true
  else
    result := false;
  if r = 0 then
    system.close(f);
end;

Solve 2:

A few days ago I was asked how to tell if a given file is already being used by another application. Finding out if a file, given its name, is in use (open), is pretty simple. The process consists in trying to open the file for Exclusive Read/Write access. If the file is already in use, it will be locked (by the calling process) for exclusive access, and the call will fail.

Please note that some application do not lock the file when using it. One clear example of this is NOTEPAD. If you open a TXT file in Notepad, the file will not be locked, so the function below will report the file as not being in use.

The function below, IsFileInUse will return true if the file is locked for exclusive access. As it uses CreateFile, it would also fail if the file doesn't exists. In my opinion, a file that doesn't exist is a file that is not in use. That's why I added the FileExists call in the function. Anyway, here's the function:

function IsFileInUse(fName: string): boolean;
var
  HFileRes: HFILE;
begin
  Result := false;
  if not FileExists(fName) then
    exit;
  HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,
    0 {this is the trick!}, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (HFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(HFileRes);
end;
  
NOTE: The function will return false if the specified file doesn't exist, meaning that it is not in use and can be used for something else.

Download file via HTTP and load in memo

Problem/Question/Abstract:

Download file via HTTP and load in memo

Answer:

This tip is based on you using NMHTTP component (FastNet).

var
  HTTP: TNMHTTP;
begin
  HTTP := TNMHTTP.Create(nil);
  HTTP.Get('http://www.somesite.com/news.htm');
  Memo1.Lines := HTTP.Body;
  HTTP.Free;
end;

Read or write in the summary information of an Office document

Problem/Question/Abstract:

How read or write in the summary information of an Offiche document ?

Answer:

An Office document file is a structured storage file that an application can read with the StgOpenStorage function from the Windows API. This kind of file is made of storages and streams.
COM defines a standard common property set for storing summary information about document. This information is stored in a stream under the root storage. The following function shows how you can get the author property by giving a filename :

uses ActiveX, ComObj, SysUtils;

function GetSummaryInfAuthor(FileName: TFileName): string;
var
  PFileName: PWideChar;
  Storage: IStorage;
  PropSetStg: IPropertySetStorage;
  PropStg: IPropertyStorage;
  ps: PROPSPEC;
  pv: PROPVARIANT;
const
  FMTID_SummaryInformation: TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
begin
  PFileName := StringToOleStr(FileName);
  try
    // Open compound storage
    OleCheck(StgOpenStorage(PFileName, nil, STGM_DIRECT or STGM_READ or
      STGM_SHARE_EXCLUSIVE, nil, 0, Storage));
  finally
    SysFreeString(PFileName);
  end;

  // Summary information is in a stream under the root storage
  PropSetStg := Storage as IPropertySetStorage;
  // Get the IPropertyStorage
  OleCheck(PropSetStg.Open(FMTID_SummaryInformation, STGM_DIRECT or STGM_READ or
    STGM_SHARE_EXCLUSIVE, PropStg));

  // We want the author property value
  ps.ulKind := PRSPEC_PROPID;
  ps.propid := PIDSI_AUTHOR;

  // Read this property
  PropStg.ReadMultiple(1, @ps, @pv);

  Result := pv.pszVal;
end;

See http://msdn.microsoft.com/library/default.asp?url=/library/en-us/com/stgasstg_7agk.asp for more information about the Summary Information Property Set.

Get the text in a TDBGrid cell before focus is moved to another cell

Problem/Question/Abstract:

How can I get the text in a cell (for TDBGrid) as the user types, but before focus is moved from that cell?

Answer:

Solve 1:

{ ... }
type
  {To access TCustomGrid.InplaceEditor declared as protected}
  TMyGrid = class(TDBGrid);

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  with TMyGrid(DBGrid1) do
    if EditorMode then
      Label1.Caption := InplaceEditor.Text;
end;


Solve 2:

My solution is very similar to Solve 1 but avoids the need for a subclass. You may prefer to have the action take place in KeyDown or KeyPress but these events generate problems when you start to edit a cell i.e. handling backspace or delete (where was the caret). For this reason it is a lot less hassle to deal with KeyUp, with this event the Editor content has been established by the time it fires. DBGrid1.Controls[0] is the InplaceEditor and below I check for its existence before trying to use it. As it is, it does not handle pasted text. You might do this by trapping WM_PASTE then testing if the Grid (not the InplaceEditor) is the ActiveControl.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if DBGrid1.ControlCount > 0 then
    Edit1.Text := TEdit(DBGrid1.Controls[0]).Text;
end;

Not select an item in a TListView

Problem/Question/Abstract:

I have a TListView which contains sequential items which may be grouped together. Users can create a group by left-clicking and dragging the mouse over a series of items. These items are regular, multiselected, highlighted (default) blue items. The user can then right-click to bring up a menu, and select Create Group. Grouped items show up in various colors, and the Data portion of the Item describes the group. I would like users to be able to edit the properties of a group by right-clicking on an item within the group to bring up a menu, then selecting Edit Group. However, whenever I right-click the listview, it highlights the item underneath the cursor, and the Create Group menu selections are enabled. Is there a way to 'turn off' the right-select? Groups are allowed to overlap, so I can't just check to see if the Item underneath is part of a group.

Answer:

You can make a listview descendent that handles the right mouse button differently.

type
  TExlistview = class(TListview)
  private
    procedure WMRButtonDown(var msg: TWMRButtonDown); message WM_RBUTTONDOWN;
    procedure WMRButtonUp(var msg: TWMRButtonUp); message WM_RBUTTONUP;
  end;

procedure TExlistview.WMRButtonDown(var msg: TWMRButtonDown);
begin
  MouseDown(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
end;

procedure TExlistview.WMRButtonUp(var msg: TWMRButtonUp);
begin
  MouseUp(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
end;

This will still fire the mouse events for the right button but do nothing of the default processing, like right select or popping up the popup menu. If you still want the menu to pop use:

procedure TExListview.WMRButtonUp(var msg: TWMRButtonUp);

  function SmallpointToScreen(const pt: TSmallpoint): Longint;
  var
    lp: TPoint;
  begin
    lp := ClientToScreen(SmallpointToPoint(pt));
    Result := LongInt(PointToSmallpoint(lp));
  end;

begin
  MouseUp(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
  Perform(WM_CONTEXTMENU, handle, SmallpointToScreen(msg.Pos));
end;

How to copy a bitmap, picture or metafile from the clipboard?

Problem/Question/Abstract:

How to copy a bitmap, picture or metafile from the clipboard?

Answer:

var
  bmp: TBitmap;
  pic: TPicture;

begin
  bmp := TBitmap.Create;

  // PICTURE OR METAFILE
  if (ClipBoard.HasFormat(CF_PICTURE)) or
    (ClipBoard.HasFormat(CF_METAFILEPICT)) then
  begin
    pic := TPicture.Create;
    pic.Assign(ClipBoard);
    X := pic.Width;
    Y := pic.Height;
    bmp.Width := X;
    bmp.Height := Y;
    bmp.Canvas.Draw(0, 0, pic.Graphic);
    pic.Free;
  end;

  // BITMAP
  if (ClipBoard.HasFormat(CF_BITMAP)) then
  begin
    bmp.Assign(ClipBoard);
  end;
  // Bitmap, picture or metafile is now in bmp
  // When used free bmp!
end;

videocard detection

Problem/Question/Abstract:

This code shows how to detect your videocard (tested on win98 & win2k)

Answer:

First form has a button create another form with a memo

procedure TForm1.button1click(Sender: TObject);
var
  lpDisplayDevice: TDisplayDevice;
  dwFlags: DWORD;
  cc: DWORD;
begin
  form2.memo1.Clear;
  lpDisplayDevice.cb := sizeof(lpDisplayDevice);
  dwFlags := 0;
  cc := 0;
  while EnumDisplayDevices(nil, cc, lpDisplayDevice, dwFlags) do
  begin
    Inc(cc);
    form2.memo1.lines.add(lpDisplayDevice.DeviceString);
      {there is also additional information in lpDisplayDevice}
    form2.show;
  end;
end;

Prevent the BDE from loosing information

Problem/Question/Abstract:

How do I prevent the BDE from loosing information in an application when the PC locks up.

Answer:

Solve 1:

Use the BDE API call DBISavechanges(handle). This will save all data in buffers directly to the database thus preventing a loss of data should anything go wrong in the current database session.

Example

Add BDE to the forms uses clause

procedure TDataform.qryEmployeeAfterPost(DataSet: TDataSet);
begin
  DBISavechanges(qryEmployee.handle);
end;


Solve 2:

unit bdeCommands;
{..
...
..
...}
uses BDE;
{...
... }

function SaveBufferToFile(Dataset: TDataset): Boolean;
begin
  Result := BDESaveChanges(Dataset);
end;

How to get detailed information about the Windows taskbar programmatically

Problem/Question/Abstract:

I'm trying to determine the edge and rectangle of the Windows taskbar, using the SHAppBarMessage API - but how do I get the Windows taskbar handle?

Answer:

I put a procedure together that gets all the information one would want to get about the TaskBar: Pos (Rect), Edge, window handle, and whether it's set to be AutoHide or AlwaysOnTop. I got the parameter and return information by following the parameter value entries within the Win32 Programmers' reference Online Help file. I also used a 1 second timer to fire the ButtonClick, so that I could test dragging and resizing the TaskBar. I'm not sure if the "Edge section" of code (ABM_GETAUTOHIDEBAR) will work properly if there are other AppBars on the system.

procedure GetTaskBarData(var AppBarInfo: TAppBarData; var AutoHide, AlwaysOnTop:
  boolean);
var
  i, RetVal: Cardinal;
begin
  fillchar(AppBarInfo, sizeof(AppBarInfo), 0);
  AppBarInfo.cbSize := sizeof(AppBarInfo);
  RetVal := ShAppBarMessage(ABM_GETSTATE, AppBarInfo);
  AutoHide := RetVal and ABS_AUTOHIDE > 0;
  AlwaysOnTop := RetVal and ABS_ALWAYSONTOP > 0;
  for i := 0 to 3 do
  begin {ask all the edges}
    AppBarInfo.uEdge := i; {then drop the Taskbar Handle into AppBarInfo}
    AppBarInfo.hWnd := ShAppBarMessage(ABM_GETAUTOHIDEBAR, AppBarInfo);
    if AppBarInfo.hWnd <> 0 then
      break;
    {the Taskbar's edge value is left in uEdge by the break}
  end;
  SHAppBarMessage(ABM_GETTASKBARPOS, AppBarInfo);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ABI: TAppBarData;
  AHide, AlOnTop: Boolean;
  s: string;
begin
  GetTaskBarData(ABI, AHide, AlOnTop);
  with ABI do
  begin
    caption := format('%d %d %d %d', [rc.left, rc.top, rc.right, rc.bottom]);
    case uEdge of
      ABE_BOTTOM: s := 'Bottom';
      ABE_LEFT: s := 'Left';
      ABE_RIGHT: s := 'Right';
      ABE_TOP: S := 'Top';
    end;
    if AHide then
      s := s + ' AutoHide';
    if AlOnTop then
      s := s + ' AlwaysOnTop';
    caption := caption + ' ' + s;
  end;
end;