Inherit forms

Problem/Question/Abstract:

How to inherit forms

Answer:

Insert the following in the OnCreate event of the descendant form:

procedure TForm1.FormCreate(Sender: TObject);
var
  DummyForm: TForm0; {Ancestor form}
  f: integer;
  tempComp: TComponent;
begin
  try
    DummyForm := TForm0.Create(Application);
    for f := DummyForm.ComponentCount - 1 downto 0 do
    begin
      {See if the component exists in the descendant form}
      tempComp := FindComponent(DummyForm.Components[f].Name);
      if not Assigned(tempComp) then
      begin
        {Doesn't exist so move it}
        tempComp := DummyForm.Components[f];
        DummyForm.RemoveComponent(tempComp);
        InsertComponent(tempComp);
        if tempComp is TControl then
          with tempComp as TControl do
            if Parent = DummyForm then
              Parent := Self;
      end;
    end;
    {Override form properties here}
    {WriteComponentsResFile('unit.dfm, Self)}- - - > {Uncommenting this will update
                the dfm file for the descentant form. Closing and then opening the form unit
                will allow you to edit the inherited components visually}
  finally
    DummyForm.Free;
  end;
end;

where TForm0 is the ancestor form.

If you wish to override a number of properties for any component, cut and paste the component in the dfm file. This will allow you to visually edit it.

Get the width and height of a *.jpg image without using a TJPEGImage

Problem/Question/Abstract:

Is there a way to get a Jpeg's height and width without using TJPEGImage? I have over 10000 images that have to be verified each month and using TJPEGImage.LoadFromFile to get the Height and Width is too slow.

Answer:

This might not work with all sorts of *.jpg images:

function GetJpegSize(const FileName: string): TPoint;
var
  fs: TFileStream;
  SegmentPos: Integer;
  SOIcount: Integer;
  x, y: word;
  b: byte;
begin
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    fs.Position := 0;
    fs.Read(x, 2);
    if x <> $D8FF then
      raise Exception.Create('Not a Jpeg file');
    SOIcount := 0;
    fs.Position := 0;
    while fs.Position + 7 < fs.Size do
    begin
      fs.Read(b, 1);
      if b = $FF then
      begin
        fs.Read(b, 1);
        if b = $D8 then
          Inc(SOIcount);
        if b = $DA then
          Break;
      end;
    end;
    if b <> $DA then
      raise Exception.Create('Corrupt Jpeg file');
    SegmentPos := -1;
    fs.Position := 0;
    while fs.Position + 7 < fs.Size do
    begin
      fs.Read(b, 1);
      if b = $FF then
      begin
        fs.Read(b, 1);
        if b in [$C0, $C1, $C2] then
        begin
          SegmentPos := fs.Position;
          Dec(SOIcount);
          if SOIcount = 0 then
            Break;
        end;
      end;
    end;
    if SegmentPos = -1 then
      raise Exception.Create('Corrupt Jpeg file');
    if fs.Position + 7 > fs.Size then
      raise Exception.Create('Corrupt Jpeg file');
    fs.Position := SegmentPos + 3;
    fs.Read(y, 2);
    fs.Read(x, 2);
    Result := Point(Swap(x), Swap(y));
  finally
    fs.Free;
  end;
end;

Convert a ADO Recordset to XML and the reverse way

Problem/Question/Abstract:

How to convert a ADO Recordset to XML and the reverse way

Answer:

unit ADOXMLUnit;

interface

uses
  Classes, ADOInt;

function RecordsetToXML(const Recordset: _Recordset): string;
function RecordsetFromXML(const XML: string): _Recordset;

implementation

uses
  ComObj;

function RecordsetToXML(const Recordset: _Recordset): string;
var
  RS: Variant;
  Stream: TStringStream;
begin
  Result := '';
  if Recordset = nil then
    Exit;
  Stream := TStringStream.Create('');
  try
    RS := CreateOleObject('ADODB.Recordset');
    RS := Recordset;
    RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistXML);
    Stream.Position := 0;
    Result := Stream.DataString;
  finally
    Stream.Free;
  end;
end;

function RecordsetFromXML(const XML: string): _Recordset;
var
  RS: Variant;
  Stream: TStringStream;
begin
  Result := nil;
  if XML = '' then
    Exit;
  try
    Stream := TStringStream.Create(XML);
    Stream.Position := 0;
    RS := CreateOleObject('ADODB.Recordset');
    RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
    Result := IUnknown(RS) as _Recordset;
  finally
    Stream.Free;
  end;
end;

end.

DBGrid To Html Table

Problem/Question/Abstract:

Deal with Font, bgColor, Alignment.
(*//
function ColorToHtml(mColor: TColor): string;
function StrToHtml(mStr: string; mFont: TFont = nil): string;
//*)

Answer:

///////Begin Source

function ColorToHtml(mColor: TColor): string;
begin
  mColor := ColorToRGB(mColor);
  Result := Format('#%.2x%.2x%.2x',
    [GetRValue(mColor), GetGValue(mColor), GetBValue(mColor)]);
end; { ColorToHtml }

function StrToHtml(mStr: string; mFont: TFont = nil): string;
var
  vLeft, vRight: string;
begin
  Result := mStr;
  Result := StringReplace(Result, '&', '&AMP;', [rfReplaceAll]);
  Result := StringReplace(Result, '<', '&LT;', [rfReplaceAll]);
  Result := StringReplace(Result, '>', '&GT;', [rfReplaceAll]);
  if not Assigned(mFont) then
    Exit;
  vLeft := Format('<FONT FACE="%s" COLOR="%s">',
    [mFont.Name, ColorToHtml(mFont.Color)]);
  vRight := '</FONT>';
  if fsBold in mFont.Style then
  begin
    vLeft := vLeft + '<B>';
    vRight := '</B>' + vRight;
  end;
  if fsItalic in mFont.Style then
  begin
    vLeft := vLeft + '<I>';
    vRight := '</I>' + vRight;
  end;
  if fsUnderline in mFont.Style then
  begin
    vLeft := vLeft + '<U>';
    vRight := '</U>' + vRight;
  end;
  if fsStrikeOut in mFont.Style then
  begin
    vLeft := vLeft + '<S>';
    vRight := '</S>' + vRight;
  end;
  Result := vLeft + Result + vRight;
end; { StrToHtml }

function DBGridToHtmlTable(mDBGrid: TDBGrid; mStrings: TStrings;
  mCaption: TCaption = ''): Boolean;
const
  cAlignText: array[TAlignment] of string = ('LEFT', 'RIGHT', 'CENTER');
var
  vColFormat: string;
  vColText: string;
  vAllWidth: Integer;
  vWidths: array of Integer;
  vBookmark: string;
  I, J: Integer;
begin
  Result := False;
  if not Assigned(mStrings) then
    Exit;
  if not Assigned(mDBGrid) then
    Exit;
  if not Assigned(mDBGrid.DataSource) then
    Exit;
  if not Assigned(mDBGrid.DataSource.DataSet) then
    Exit;
  if not mDBGrid.DataSource.DataSet.Active then
    Exit;
  vBookmark := mDBGrid.DataSource.DataSet.Bookmark;
  mDBGrid.DataSource.DataSet.DisableControls;
  try
    J := 0;
    vAllWidth := 0;
    for I := 0 to mDBGrid.Columns.Count - 1 do
      if mDBGrid.Columns[I].Visible then
      begin
        Inc(J);
        SetLength(vWidths, J);
        vWidths[J - 1] := mDBGrid.Columns[I].Width;
        Inc(vAllWidth, mDBGrid.Columns[I].Width);
      end;
    if J <= 0 then
      Exit;
    mStrings.Clear;
    mStrings.Add(Format('<TABLE BGCOLOR="%s" BORDER=1 WIDTH="100%%">',
      [ColorToHtml(mDBGrid.Color)]));
    if mCaption <> '' then
      mStrings.Add(Format('<CAPTION>%s</CAPTION>', [StrToHtml(mCaption)]));
    vColFormat := '';
    vColText := '';
    vColFormat := vColFormat + '<TR>'#13#10;
    vColText := vColText + '<TR>'#13#10;
    J := 0;
    for I := 0 to mDBGrid.Columns.Count - 1 do
      if mDBGrid.Columns[I].Visible then
      begin
        vColFormat := vColFormat + Format(
          '  <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">DisplayText%d</TD>'#13#10,
          [ColorToHtml(mDBGrid.Columns[I].Color),
          cAlignText[mDBGrid.Columns[I].Alignment],
            Round(vWidths[J] / vAllWidth * 100), J]);
        vColText := vColText + Format(
          '  <TD BGCOLOR="%s" ALIGN=%s WIDTH="%d%%">%s</TD>'#13#10,
          [ColorToHtml(mDBGrid.Columns[I].Title.Color),
          cAlignText[mDBGrid.Columns[I].Alignment],
            Round(vWidths[J] / vAllWidth * 100),
            StrToHtml(mDBGrid.Columns[I].Title.Caption,
            mDBGrid.Columns[I].Title.Font)]);
        Inc(J);
      end;
    vColFormat := vColFormat + '</TR>'#13#10;
    vColText := vColText + '</TR>'#13#10;
    mStrings.Text := mStrings.Text + vColText;
    mDBGrid.DataSource.DataSet.First;
    while not mDBGrid.DataSource.DataSet.Eof do
    begin
      J := 0;
      vColText := vColFormat;
      for I := 0 to mDBGrid.Columns.Count - 1 do
        if mDBGrid.Columns[I].Visible then
        begin
          vColText := StringReplace(vColText, Format('>DisplayText%d<', [J]),
            Format('>%s<', [StrToHtml(mDBGrid.Columns[I].Field.DisplayText,
              mDBGrid.Columns[I].Font)]),
            [rfReplaceAll]);
          Inc(J);
        end;
      mStrings.Text := mStrings.Text + vColText;
      mDBGrid.DataSource.DataSet.Next;
    end;
    mStrings.Add('</TABLE>');
  finally
    mDBGrid.DataSource.DataSet.Bookmark := vBookmark;
    mDBGrid.DataSource.DataSet.EnableControls;
    vWidths := nil;
  end;
  Result := True;
end; { DBGridToHtmlTable }
///////End Source

{ uses ShellApi; }

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);
begin
  DBGridToHtmlTable(DBGrid1, Memo1.Lines, Caption);
  Memo1.Lines.SaveToFile('c:\temp.htm');
  ShellExecute(Handle, nil, 'c:\temp.htm', nil, nil, SW_SHOW);
end;
///////End Demo

How to reverse the byte order of integer values of all sizes

Problem/Question/Abstract:

I need to reverse the byte order of various integer values for an application. What would be the best way to do this big-endian/ little-endian swap? Note: I need to convert values of all sizes (word .. int64 ).

Answer:

Solve 1:

function EndianWord(w: word): word;
begin
  result := swap(w);
end;

function EndianInt(i: integer): integer;
begin
  result := swap(i);
end;

function EndianLong(L: longint): longint;
begin
  result := swap(L shr 16) or (longint(swap(L and $FFFF)) shl 16);
end;


Solve 2:

One could use the Swap function, but the problem with it is that it only swaps words or integers. I wrote thefollowing function to swap anything:

procedure SwapBytes(var Bytes; Len: Integer);
var
  Swapped: PChar;
  i: Integer;
begin
  GetMem(Swapped, Len);
  try
    for i := 0 to Len - 1 do
      Swapped[Len - i - 1] := PChar(@Bytes)[i];
    Move(Swapped^, Bytes, Len);
  finally
    FreeMem(Swapped);
  end;
end;

Usage:

SwapBytes(i, sizeof(i));


Solve 3:

unit Swap;

interface

type
  TData1 = word; {Is actually 2 bytes for alignment}
  TData2 = word;
  TData4 = cardinal;
  TData8 = double;
  PData2 = ^TData2;

function Swap2(a: cardinal): word;
function Swap4(a: cardinal): cardinal;
function Swap2Signed(a: cardinal): smallint;
function Swap4Signed(a: cardinal): longint;
procedure Swap4Array(a, b: pointer; n: integer);
procedure Swap2Array(a, b: pointer; n: integer);
procedure SwapDoubleTo8(const a: double; var b: TData8);
function Swap8ToDouble(var a: TData8): double;

implementation

function Swap2(a: cardinal): word;
asm
  bswap eax
  shr eax,16
end;

function Swap2signed(a: cardinal): smallint;
asm
  bswap eax
  shr eax,16
end;

function Swap4(a: cardinal): cardinal;
asm
  bswap eax
end;

function Swap4Signed(a: cardinal): longint;
asm
  bswap eax
end;

procedure Swap2Array(a, b: pointer; n: integer);
asm
  push ebx
  xor ebx, ebx
  lea eax, [eax + ecx * 2]
  lea edx, [edx + ecx * 2]
  sub ebx, ecx
  @L1:
  mov cx, word ptr[eax + ebx * 2]
  bswap cx
  mov word ptr[edx + ebx * 2], cx
  inc ebx
  jnz @L1
  pop ebx
end;

procedure Swap4Array(a, b: pointer; n: integer);
asm
  push ebx
  xor ebx, ebx
  lea eax, [eax + ecx * 4]
  lea edx, [edx + ecx * 4]
  sub ebx, ecx
  @L1:
  mov ecx, dword ptr[eax + ebx * 4]
  bswap ecx
  mov dword ptr[edx + ebx * 4], ecx
  inc ebx
  jnz @L1
  pop ebx
end;

procedure SwapDoubleTo8(const a: double; var b: TData8);
asm
  mov edx, dword ptr[a]
  mov ecx, dword ptr[a + 4]
  bswap edx
  bswap ecx
  mov dword ptr [eax], ecx
  mov dword ptr [eax + 4], edx
end;

function Swap8ToDouble(var a: TData8): double;
var
  hold: double;
asm
  mov edx, dword ptr[eax]
  mov ecx, dword ptr[eax + 4]
  bswap edx
  bswap ecx
  mov dword ptr [hold], ecx
  mov dword ptr [hold + 4], edx
  fld hold;
end;

procedure SwapInt64To8(const a: int64; var b: TData8);
asm
  mov edx, dword ptr[a]
  mov ecx, dword ptr[a + 4]
  bswap edx
  bswap ecx
  mov dword ptr [eax], ecx
  mov dword ptr [eax + 4], edx
end;

function Swap8ToInt64(var a: TData8): int64;
asm
  mov edx, dword ptr[eax + 4]
  mov eax, dword ptr[eax]
  bswap edx
  bswap eax
end;

end.

How to reset a Paradox AutoInc field

Problem/Question/Abstract:

Aside from using the Database Desktop to copy the structure of a Paradox table to a new one, is there a way or a utility to reset a Paradox AutoInc to one (for any empty table) or to the next number after the maximum value for the field?

Answer:

You would have to restructure the table and change the field type to long integer then restructure the table and change the field type back to autoinc. An alternative is to generate your own autoinc value. Create a single field single record table to hold the last number used then use the following code to get the next value.

function dgGetUniqueNumber(LastNumberTbl: TTable): LongInt;
{Gets the next value from a one field one record table which stores the last used value in its first field. The parameter LastNumberTbl is the table that contains the last used number.}
const
  ntMaxTries = 100;
var
  I, WaitCount, Tries: Integer;
  RecordLocked: Boolean;
  ErrorMsg: string;
begin
  Result := 0;
  Tries := 0;
  with LastNumberTbl do
  begin
    {Make sure the table contains a record.  If not, add one and set the first field to zero.}
    if RecordCount = 0 then
    begin
      Insert;
      Fields[0].AsInteger := 0;
      Post;
    end;
    {Try to put the table that holds the last used number into edit mode. If calling Edit raises an
    exception wait a random period and try again}
    Randomize;
    while Tries < ntMaxTries do
    try
      Inc(Tries);
      Edit;
      Break;
    except
      on E: EDBEngineError do
        {The call to Edit failed because the record could not be locked.}
      begin
        {See if the lock failed because the record is locked by another user}
        RecordLocked := False;
        for I := 0 to Pred(E.ErrorCount) do
          if E: Errors[I].ErrorCode = 10241 then
            RecordLocked := True;
        if RecordLocked then
        begin
          {Wait for a random period and try again}
          WaitCount := Random(20);
          for I := 1 to WaitCount do
            Application.ProcessMessages;
          Continue;
        end
        else
        begin
          {The record lock failed for some reason other than another user has the record locked.
          Display the BDE error stack and exit}
          ErrorMsg := '';
          for I := 0 to Pred(E.ErrorCount) do
            ErrorMsg := ErrorMsg + E.Errors[I].Message + ' (' + IntToStr(E.Errors[I].ErrorCode) + '). ';
          MessageDlg(ErrorMsg, mtError, [mbOK], 0);
          Exit;
        end;
      end;
    end;
    if State = dsEdit then
    begin
      Result := Fields[0].AsInteger + 1;
      Fields[0].AsInteger := Result;
      Post;
    end
    else
      {If the record could not be locked after the specified number of tries raise an exception}
      raise Exception.Create('Cannot get next unique number. (dgGetUniqueNumber)');
  end;
end;

Show a window "TopMost" - even when it is inactive

Problem/Question/Abstract:

Show a window "TopMost" - even when it is inactive

Answer:

To show a window above all other windows even when it is not the active window/ active application, use this API call:

SetWindowPos(Form1.handle, HWND_TopMost, 0, 0, 0, 0,
  SWP_NoMove or SWP_NoSize or SWP_ShowWindow);

Merge two menus

Problem/Question/Abstract:

I would like to merge one menu into another. Is there an easy way to do this?

Answer:

Something like this. If you don't want to delete the item from PopupMenu2, you'll have to create a new item.

{ ... }
var
  Item: TMenuItem;
begin
  with PopupMenu2.Items do
    while Count <> 0 do
    begin
      Item := Items[0];
      Delete(0);
      PopupMenu1.Items.Add(Item);
    end;

How to use JPEG images stored in resource files

Problem/Question/Abstract:

How can I load a JPEG image from a resource file that is linked with my application?

Answer:

The following demonstrates creating a resource file containing a JPEG image, and loading the JPEG file from the resource file. The resulting JPEG image is displayed in a Image component.

Create a text file with the extension of ".rc". The text file should be named something different than the project name or any unit name in your application to avoid any confusion for the compiler. The text file should contain the following line:

MYJPEG JPEG C:\DownLoad\MY.JPG

Where "MYJPEG" is the name you wish to name the resource "JPEG" is the user defined resource type. "C:\DownLoad\MY.JPG" is the path and filename of the JPEG file. For our example we will name the file "foo.rc".

Now run the BRCC32.exe (Borland Resource CommandLine Compiler) program found in the Delphi/C++ Builders bin directory giving the full path to the rc file:

C:\DelphiPath\BIN\BRCC32.EXE C:\ProjectPath\FOO.RC

You should now have a compiled resource file named the same as the ".rc" file you compiled with the extension of ".res".

The following demonstrates using the embedded JPEG in your application:

{Link the res file}
{$R FOO.RES}

uses
  Jpeg;

procedure LoadJPEGFromRes(TheJPEG: string; ThePicture: TPicture);
var
  ResHandle: THandle;
  MemHandle: THandle;
  MemStream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
  JPEGImage: TJPEGImage;
begin
  ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
  MemHandle := LoadResource(hInstance, ResHandle);
  ResPtr := LockResource(MemHandle);
  MemStream := TMemoryStream.Create;
  JPEGImage := TJPEGImage.Create;
  ResSize := SizeOfResource(hInstance, ResHandle);
  MemStream.SetSize(ResSize);
  MemStream.Write(ResPtr^, ResSize);
  FreeResource(MemHandle);
  MemStream.Seek(0, 0);
  JPEGImage.LoadFromStream(MemStream);
  ThePicture.Assign(JPEGImage);
  JPEGImage.Free;
  MemStream.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;

How to have MessageDlg() play the corresponding sound

Problem/Question/Abstract:

How to have MessageDlg() play the corresponding sound

Answer:

Application.MessageBox() and the Windows API function MessageBox() each play the system sound associated with the type of the message, but the VCL function MessageDlg does not. You have to call the API function MessageBeep() before you call MessageBox().

Replace your calls to MessageDlg() with MessageDlgSound() from the example below.

  
function MessageDlgSound(const Msg: string;
  DlgType: TMsgDlgType;
  Buttons: TMsgDlgButtons;
  HelpCtx: Longint): Word;
const
  Sounds: array[TMsgDlgType] of integer = (
    MB_ICONEXCLAMATION, MB_ICONHAND, MB_OK, MB_ICONQUESTION, MB_ICONASTERISK);
begin
  MessageBeep(Sounds[DlgType]);
  Result := MessageDlg(Msg, DlgType, Buttons, HelpCtx);
end;

How to convert TColor values to RGB or HLS values and vice versa

Problem/Question/Abstract:

How to convert TColor values to RGB or HLS values and vice versa

Answer:

unit ColorConv;

interface

uses
  Graphics;

type
  TRGB = record
    R: Integer;
    G: Integer;
    B: Integer;
  end;

type
  THLS = record
    H: Integer;
    L: Integer;
    S: Integer;
  end;

type
  THWB = record
    H: Integer;
    W: Integer;
    B: Integer;
  end;

function ColorToRGB(PColor: TColor): TRGB;
function RGBToColor(PR, PG, PB: Integer): TColor;
function RGBToCol(PRGB: TRGB): TColor;
function RGBToHLS(PRGB: TRGB): THLS;
function HLSToRGB(PHLS: THLS): TRGB;
function min(P1, P2, P3: double): Double;
function max(P1, P2, P3: double): Double;

implementation

{Convert separate RGB integer values to the Delphi Color Class}

function RGBToColor(PR, PG, PB: Integer): TColor;
begin
  Result := TColor((PB * 65536) + (PG * 256) + PR);
end;

{Convert the Delphi color class into RGB values that are held in the TRGB format}

function ColorToRGB(PColor: TColor): TRGB;
var
  i: Integer;
begin
  i := PColor;
  Result.R := 0;
  Result.G := 0;
  Result.B := 0;
  while i - 65536 >= 0 do
  begin
    i := i - 65536;
    Result.B := Result.B + 1;
  end;
  while i - 256 >= 0 do
  begin
    i := i - 256;
    Result.G := Result.G + 1;
  end;
  Result.R := i;
end;

{Convert a TRGB value to TColor}

function RGBToCol(PRGB: TRGB): TColor;
begin
  Result := RGBToColor(PRGB.R, PRGB.G, PRGB.B);
end;

{Convert a TRGB color to a THLS class }

function RGBToHLS(PRGB: TRGB): THLS;
var
  LR, LG, LB, LH, LL, LS, LMin, LMax: double;
  LHLS: THLS;
  i: Integer;
begin
  LR := PRGB.R / 256;
  LG := PRGB.G / 256;
  LB := PRGB.B / 256;
  LMin := min(LR, LG, LB);
  LMax := max(LR, LG, LB);
  LL := (LMax + LMin) / 2;
  if LMin = LMax then
  begin
    LH := 0;
    LS := 0;
    Result.H := round(LH * 256);
    Result.L := round(LL * 256);
    Result.S := round(LS * 256);
    exit;
  end;
  if LL < 0.5 then
    LS := (LMax - LMin) / (LMax + LMin);
  if LL >= 0.5 then
    LS := (LMax - LMin) / (2.0 - LMax - LMin);
  if LR = LMax then
    LH := (LG - LB) / (LMax - LMin);
  if LG = LMax then
    LH := 2.0 + (LB - LR) / (LMax - LMin);
  if LB = LMax then
    LH := 4.0 + (LR - LG) / (LMax - LMin);
  Result.H := round(LH * 42.6);
  Result.L := round(LL * 256);
  Result.S := round(LS * 256);
end;

{Convert HLS values into RGB values}

function HLSToRGB(PHLS: THLS): TRGB;
var
  LR, LG, LB, LH, LL, LS: double;
  LHLS: THLS;
  L1, L2: Double;
begin
  LH := PHLS.H / 255;
  LL := PHLS.L / 255;
  LS := PHLS.S / 255;
  if LS = 0 then
  begin
    Result.R := PHLS.L;
    Result.G := PHLS.L;
    Result.B := PHLS.L;
    Exit;
  end;
  if LL < 0.5 then
    L2 := LL * (1.0 + LS);
  if LL >= 0.5 then
    L2 := LL + LS - LL * LS;
  L1 := 2.0 * LL - L2;
  LR := LH + 1.0 / 3.0;
  if LR < 0 then
    LR := LR + 1.0;
  if LR > 1 then
    LR := LR - 1.0;
  if 6.0 * LR < 1 then
    LR := L1 + (L2 - L1) * 6.0 * LR
  else if 2.0 * LR < 1 then
    LR := L2
  else if 3.0 * LR < 2 then
    LR := L1 + (L2 - L1) * ((2.0 / 3.0) - LR) * 6.0
  else
    LR := L1;
  LG := LH;
  if LG < 0 then
    LG := LG + 1.0;
  if LG > 1 then
    LG := LG - 1.0;
  if 6.0 * LG < 1 then
    LG := L1 + (L2 - L1) * 6.0 * LG
  else if 2.0 * LG < 1 then

    LG := L2
  else if 3.0 * LG < 2 then
    LG := L1 + (L2 - L1) * ((2.0 / 3.0) - LG) * 6.0
  else
    LG := L1;
  LB := LH - 1.0 / 3.0;
  if LB < 0 then
    LB := LB + 1.0;
  if LB > 1 then
    LB := LB - 1.0;
  if 6.0 * LB < 1 then
    LB := L1 + (L2 - L1) * 6.0 * LB
  else if 2.0 * LB < 1 then
    LB := L2
  else if 3.0 * LB < 2 then
    LB := L1 + (L2 - L1) * ((2.0 / 3.0) - LB) * 6.0
  else
    LB := L1;
  Result.R := round(LR * 255);
  Result.G := round(LG * 255);
  Result.B := round(LB * 255);
end;

{Internal routine used to convert RGB to HLS}

function max(P1, P2, P3: double): Double;
begin
  Result := -1;
  if (P1 > P2) then
  begin
    if (P1 > P3) then
    begin
      Result := P1;
    end
    else
    begin
      Result := P3;
    end;
  end
  else if P2 > P3 then
  begin
    result := P2;
  end
  else
    result := P3;
end;

{Internal routine used to convert RGB to HLS}

function min(P1, P2, P3: double): Double;
begin
  Result := -1;
  if (P1 < P2) then
  begin
    if (P1 < P3) then
    begin
      Result := P1;
    end
    else
    begin
      Result := P3;
    end;
  end
  else if P2 < P3 then
  begin
    result := P2;
  end
  else
    result := P3;
end;

end.

Use my own Inplace-Editors in Grids

Problem/Question/Abstract:

String-Grids are very usefull, but sometimes it's necessary to use an own Inplace-Editor. For example to make a Grid which will allow only numbers but no Text-Characters.

Answer:

When you are using Grids (TStringGrid, TDBGrid), you can input some text in the cells of the grid. This will be done with the "Inplace-Editor" from Borland.

Sometimes it's necessary to make an own Inplace-Editor, for example to prevent the user to give in Text instead of number. The following example shows how to do this.

First you need two new classes: one for your Grid and one for your Inplace-Editor. In this example I use TStringGrid, but it should also work with TDBStringGrid.

unit u_TMyStringGrid;

interface

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

type

  // My own Inplace-Editor. This Editor -for example- only
  // allow numbers, no text
  TMyInplaceEdit = class(TInplaceEdit)
  protected
    procedure KeyPress(var Key: Char); override;
  end;

  // My own StringGrid, which will use my own Inplace-Editor
  TMyStringGrid = class(TStringGrid)
  protected
    function CreateEditor: TInplaceEdit; override;
  end;

implementation

{ TMyStringGrid }
// Here i define, that my StringGrid should use MyInplace-Editor

function TMyStringGrid.CreateEditor: TInplaceEdit;
begin
  Result := TMyInplaceEdit.Create(Self);
end;

{ TMyInplaceEdit }
//The Inplace-Edit only allowes numers, no text-Characters

procedure TMyInplaceEdit.KeyPress(var Key: Char);
begin
  if not (Key in ['0'..'9']) then
  begin
    beep;
    Key := #0
  end
  else
    inherited;
end;

end.

How to get the HTML code for the parent of an ActiveX form

Problem/Question/Abstract:

Does anyone know how to get the HTML code for the parent of an ActiveX form? The problem we have is an ActiveX Form which is loaded into a HTML document. This ActiveX form has buttons on it to load additional ActiveX forms. We want to place these additional ActiveX forms onto the current HTML page into a frame.

Answer:

The code below shows you how to grab the document, etc., from an ActiveForm.


uses
  ActiveX;

{ ... }

FBrowser: IWebBrowser2;

TYourActiveForm.YourMethod;
var
  vClientSite: IOLEClientSite; {ActiveX}
  vContainer: IOLEContainer; {ActiveX}
  vServiceProvider: IServiceProvider; {ActiveX}
  vDocument: IHTMLDocument2; {MSHTML_TLB}
  vBackgroundImage: OleVariant;
begin
  vClientSite := ActiveFormControl.ClientSite;
  vClientSite.GetContainer(vContainer);
  if vContainer.QueryInterface(IServiceProvider, vServiceProvider) = S_OK then
  begin
    if vServiceProvider.QueryService(IID_IWebBrowserApp, IID_IWebBrowser2,
      FBrowser) = S_OK then
    begin
      vDocument := FBrowser.Document as IHTMLDocument2;
      vBackgroundImage := vDocument.body.style.backgroundImage;
      if vBackgroundImage = '' then
        vBackgroundImage := vDocument.body.getAttribute('background', 0);
      if vBackgroundImge <> '' then
        ShowMessage(vBackgroundImage)
      else
        ShowMessage('No background image defined.');
    end;
  end;
end;

How to create and insert a *.wmf into an *.rtf file

Problem/Question/Abstract:

How to create and insert a *.wmf into an *.rtf file

Answer:

Well, create a metafile with the old wmf format (with enhanced = false). Code like this works:


{ ... }
var
  f: TPicture;
  c: TMetafileCanvas;
  fs: TMemoryStream;
begin
  f := TPicture.create;
  f.Metafile.width := 100;
  f.Metafile.height := 100;
  f.Metafile.Enhanced := false;
  c := TMetafileCanvas.create(f.Metafile, 0);
  c.Ellipse(5, 5, 95, 95);
  c.Free;
end;


Get the bytes of the metafile, put in a buffer and call this function:


procedure TRtfWriter.InsertWMFFromBuffer(Buffer: PByte; const BufLen: integer;
  iWidth, iHeight: integer);
var
  wmfTag: string;
  HexEncoded: string;
  i: integer;
begin
  HexEncoded := '';
  for i := 0 to BufLen - 1 do
  begin
    HexEncoded := HexEncoded + IntToHex(Buffer^, 2);
    Inc(Buffer);
  end;
  {You gotta skip the wmf header}
  HexEncoded := Copy(HexEncoded, (Sizeof(LongInt) + Sizeof(SmallInt) + Sizeof(TSmallRect) +
    Sizeof(Word) + Sizeof(LongInt) + Sizeof(Word)) * 2 + 1,
    Length(HexEncoded));
  HexEncoded := LowerCase(HexEncoded);
  wmfTag := '{\pict\wmetafile8\picw%d\pich%d %s }';
  wmfTag := Format(wmfTag, [iWidth * 20, iHeight * 20, HexEncoded]);
  fStream.Write(wmfTag[1], Length(wmfTag));
end;



Note that fStream is a stream with the rtf file my TRtfWriter class is working on. You'll have to the the rtf job yourself, but that's the way to inser a wmf file. If you want a quick test, place this on the top of the file:



{\rtf1\ansi\ansicpg1252\deff0\deflang1046{\fonttbl{\f0\fswiss\fprq2\fcharset
0 Verdana;}{\f1\fswiss\fcharset0 Arial;}   {\f2\fmodern\fprq1\fcharset0
Courier New;}}\viewkind4\uc1


and this on the bottom


\par}

Delete a TFrame together with its parent TTabSheet

Problem/Question/Abstract:

I have a form with a page control, and each tab sheet of the page control contains a frame. I would like to delete the frame along with the parent tab sheet if the user clicks a certain button on the frame. What's the best way to do this? It seems that if the tab sheet's free method is called from inside the button-click event handler, the button will be freed before the event handler is finished executing.

Answer:

The way to solve this is do like TCustomform.Release does it: post (via PostMessage) a user message to the form, have the form free the component in response to the message.

const
  UM_DESTROYCONTROL = WM_USER + 230;

  {in form declaration}
  private
    { Private declarations }

procedure UmDestroyControl(var msg: TMessage); message UM_DESTROYCONTROL;

{in the buttons OnClick handler}

var
  ctrl: TWinControl;
begin
  ctrl := GetParentForm(Sender as TButton);
  PostMessage(ctrl.handle, UM_DESTROYCONTROL, 0, Integer(Sender));
  { ... }

procedure TForm1.UmDestroyControl(var msg: TMessage);
begin
  TObject(msg.lparam).Free;
end;

How to get the TMediaPlayer to show the first frame of an AVI file

Problem/Question/Abstract:

How to get the TMediaPlayer to show the first frame of an AVI file

Answer:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.ProcessMessages;
  MediaPlayer1.Open;
  Application.ProcessMessages;
  MediaPlayer1.Step;
  MediaPlayer1.Previous;
end;

How to insert text into a TComboBox at the last cursor position

Problem/Question/Abstract:

The goal is to insert a string into the text in a TComboBox at the last cursor position. An assignment like edInput.SelText := newText; works fine with a TEdit when AutoSelect = false, but not with combobox. SelStart always returns 0 after exiting. So no matter where the user had the cursor, the text is always inserted at the front. Is there a quick workaround for this?

Answer:

Assign the Combobox.selstart value to a variable on the KeyUp event of the combobox and call the variable when you need the position. You can take the hint as a variable or declare your own variable.

procedure TForm1.ComboBox1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  ComboBox1.hint := inttostr(Combobox1.selstart);
end;

Add programs to the Windows start menu

Problem/Question/Abstract:

How to add programs to the Windows start menu

Answer:

Solve 1:

procedure CreateStartmenuLink(ExeFile, WorkPath, Args, Descr: string);
var
  MyObject: IUnknown;
  MyLink: IShellLink;
  MyFile: IPersistFile;
  ds: WideString;
  StartMenuDir: string;
  reg_info: TRegIniFile;
  reg: TRegistry;
  s: string;
begin
  reg_Info :=
    TRegIniFile.Create('Software\Microsoft\Windows\CurrentVersion\Explorer');
  StartMenuDir := reg_Info.ReadString('Shell Folders', 'Start Menu', '');
  reg_Info.Free;
  s := ExtractFilePath(StartMenuDir + '\' + Descr + '.lnk');
  ForceDirectories(s);
  if FileExists(StartMenuDir + '\' + Descr + '.lnk') then
    DeleteFile(StartMenuDir + '\' + Descr + '.lnk');
  MyObject := CreateComObject(CLSID_ShellLink);
  MyLink := MyObject as IShellLink;
  MyFile := MyObject as IPersistFile;
  MyLink.SetArguments(PChar(Args));
  MyLink.SetPath(PChar(ExeFile));
  MyLink.SetWorkingDirectory(PChar(WorkPath));
  s := ExtractFileName(StartMenuDir + '\' + Descr + '.lnk');
  s := copy(s, 1, length(s) - 4);
  MyLink.SetDescription(PChar(s));
  ds := StartMenuDir + '\' + Descr + '.lnk';
  MyFile.Save(PWChar(ds), false);
  reg := TRegistry.Create;
  reg.RootKey := HKEY_USERS;
  reg.openkey('.Default\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', true);
  StartMenuDir := reg.ReadString('Start Menu');
  reg.closekey;
  reg.free;
  s := ExtractFilePath(StartMenuDir + '\' + Descr + '.lnk');
  ForceDirectories(s);
  if FileExists(StartMenuDir + '\' + Descr + '.lnk') then
    DeleteFile(StartMenuDir + '\' + Descr + '.lnk');
  ds := StartMenuDir + '\' + Descr + '.lnk';
  MyFile.Save(PWChar(ds), false);
end;


Solve 2:

{uses Windows, ShlObj, SysUtils, ...}

type
  TShellLinkInfo = record
    PathName: string;
    Arguments: string;
    Description: string;
    WorkingDirectory: string;
    IconLocation: string;
    IconIndex: integer;
    ShowCmd: integer;
    HotKey: word;
  end;

function GetSpecialFolderPath(Folder: Integer; CanCreate: Boolean):
  string;
var
  FilePath: array[0..MAX_PATH] of char;
begin
  { Get path of selected location }
  SHGetSpecialFolderPath(0, FilePath, Folder, CanCreate);
  Result := FilePath;
end;

function CreateShellLink(const AppName, Desc: string; Dest: Integer): string;
{ Creates a shell link for application or document specified in  AppName with description Desc.
Link will be located in folder specified by Dest. Returns the full path name of the link file }
var
  SL: IShellLink;
  PF: IPersistFile;
  LnkName: WideString;
begin
  OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink,
    SL));
  { The IShellLink implementer must also support the IPersistFile interface.
  Get an interface pointer to it. }
  PF := SL as IPersistFile;
  OleCheck(SL.SetPath(PChar(AppName))); {set link path to proper file}
  if Desc <> '' then
    OleCheck(SL.SetDescription(PChar(Desc))); {set description}
  { create a path location and filename for link file }
  LnkName := GetSpecialFolderPath(Dest, True) + '\' + ChangeFileExt(AppName, '.lnk');
  PF.Save(PWideChar(LnkName), True); {save link file}
  Result := LnkName;
end;

Usage:

CreateShellLink('c:\programfiles\mycompany\myapp.exe', '', CSIDL_PROGRAMS);

Look up SHGetSpecialFolderLocation or "ShlObj.pas" for the CSIDL_constants.

Create a popup menu for a tab of a TPageControl

Problem/Question/Abstract:

How to create a popup menu for a tab of a TPageControl

Answer:

{ ... }
uses
  commctrl;

procedure TabMenuPopup(APageControl: TPageControl; X, Y: Integer; );
var
  hi: TTCHitTestInfo;
  TabIndex: Integer;
  p: TPoint;
begin
  hi.pt.x := X;
  hi.pt.y := Y;
  hi.flags := 0;
  TabIndex := APageControl.Perform(TCM_HITTEST, 0, longint(@hi));
  p.x := APageControl.Left + X;
  p.y := APageControl.Top + y;
  p := ClientToScreen(p);
  {Allows use of different menus for each tab...}
  case TabIndex of
    0: {on the first tab...}
      PopupMenu1.Popup(P.x, P.Y);
    1: {on the second tab...}
      PopupMenu2.Popup(P.x, P.Y);
  end;
end;
end;

procedure TForm1.PageControl1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbRight then
  begin
    TabMenuPopup(PageControl1, X, Y);
  end;
end;

HTML Help File implementation in Delphi

Problem/Question/Abstract:

How do I implement HTML help in my application?

Answer:

There is not much info around about Help file implementation in an application, let alone HTML Help!!! But an Australian company has made it alot easier for us. Visit this site and see how easy it is to use the new Microsoft HTML Help system. You simply create your help file in MS Frontpage or similar and then compile it with the MS HTML HELP KIT. Use the Unit supplied and use the following simple procedure to reference the correct heading in the HTML file:

HHDisplayTopic('mtshelp.chm', 'departmentsgroups.htm', '', htHHAPI);

Here is HelpWares address : http://www.helpware.net/delphi/delphi_and_hh.htm

Download "The Kit"

I have used this unit very successfully!

Retrieve DFM files from the executable

Problem/Question/Abstract:

Retrieve DFM files from the EXEcutable

Answer:

Delphi Form Files (.dfm) are stored as normal Windows binary resources (rcData) in your executable. Examples of other resources in an .exe: bitmaps, cursors, icons, and strings.

You can use a utility such as Resource Workshop, or the Resource Explorer demo application which comes with D3 (demos\resxplor), to extract any resource from an .exe into a separate file. This means you could easily extract a .dfm resource from the .exe into a separate file.

You can also use the Delphi TResourceStream class to access resource data as a stream, and you can easily copy a resource stream to another stream, such as a file stream or memory stream.

Once you have extracted the .dfm from the .exe, you can use .dfm utility procedures such as ObjectBinaryToText, ObjectTextToBinary, ReadComponentResFile, WriteComponentResFile, TStream.ReadComponent, TStream.WriteComponent, etc., to manipulate the .DFM.

How to extract all strings between a predetermined start and end point

Problem/Question/Abstract:

Could someone share some code that would extract all strings between 'start' and 'end'. I'm trying to load a document in TMemo and delete all strings not found inside a predetermined start and end point.

Answer:

function TextBetweenStartAndEnd(const Text: string): string;
var
  pStart, pEnd: PChar;
begin
  {sets a pointer to the "start" position}
  pStart := StrPos(PChar(Text), 'start');
  if Assigned(pStart) then
  begin
    {sets a pointer behind the "start" position}
    Inc(pStart, Length('start'));
    {looking for the "end" position}
    pEnd := StrPos(pStart, 'end');
    {copies the text between the "start" and "end" position}
    if Assigned(pEnd) then
      Result := Copy(string(pStart), 1, pEnd - pStart);
  end;
  {if no "start" or "end" then raise an exception}
  if (not Assigned(pStart)) or (not Assigned(pEnd)) then
    raise Exception.Create('Error parsing text!');
end;

How to determine the path of a TTable

Problem/Question/Abstract:

How to determine the path of a TTable

Answer:

Solve 1:

When a Table is referenced through an alias, the physical path is not readily available. To obtain this path, use the DbiGetDatabaseDesc BDE function. This function takes the alias name and a pointer to a DBDesc structure. The DBDesc structure will be filled with the information pertaining to that alias. This structure is defined as:


pDBDesc = ^DBDesc;
DBDesc = packed record { A given Database Description }
  szName: DBINAME; { Logical name (Or alias) }
  szText: DBINAME; { Descriptive text }
  szPhyName: DBIPATH; { Physical name/path }
  szDbType: DBINAME; { Database type }
end;

The physical name/path will be contained in the szPhyName field of the DBDesc structure. Possible return values for the DBIGetDatbaseDesc function are:

DBIERR_NONE
The database description for pszName was retrieved successfully.

DBIERR_OBJNOTFOUND
The database named in pszName was not found.

The code example below illustrates how to obtain the physical path name of a TTable component using the DBDemos alias:

var
  vDBDesc: DBDesc;
  DirTable: string;
begin
  Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
  DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
  ShowMessage(DirTable);
end;


Solve 2:

Here are three ways to get the path associated with an alias. a) is for permanent aliases only. b) works on BDE and local aliases and c) works with BDE and local aliases as well as with tables with a hardcoded path, using DBI calls.

a) For permanent aliases only

function GetDBPath1(AliasName: string): TFileName;
var
  ParamList: TStringList;
begin
  ParamList := TStringList.Create;
  with Session do
  try
    GetAliasParams(AliasName, ParamList);
    Result := UpperCase(ParamList.Values['PATH']) + '\';
  finally
    Paramlist.Free;
  end;
end;

b) Works on BDE and local aliases

function GetDBPath2(AliasName: string): TFileName;
var
  ParamList: TStringList;
  i: integer;
begin
  ParamList := TStringList.Create;
  with Session do
  try
    try
      GetAliasParams(AliasName, ParamList);
    except
      for i := 0 to pred(DatabaseCount) do
        if (Databases[i].DatabaseName = AliasName) then
          ParamList.Assign(Databases[i].Params);
    end;
    Result := UpperCase(ParamList.Values['PATH']) + '\';
  finally
    Paramlist.Free;
  end;
end;

c) The following example assumes the TTable being active

function GetDBPath3(ATable: TTable): TFileName;
var
  TblProps: CURProps;
  pTblName, pFullName: DBITblName;
begin
  with ATable do
  begin
    AnsiToNative(Locale, TableName, pTblName, 255);
    Check(DBIGetCursorProps(Handle, TblProps));
    Check(DBIFormFullName(DBHandle, pTblName, TblProps.szTableType, pFullName));
    Result := ExtractFilePath(StrPas(pFullName));
  end;
end;

Personal settings and ini-files

Problem/Question/Abstract:

This article illustrates the usage of the TInifile object, and gives guideline when and how to use ini files for the storage of personal settings.

Answer:

This article is part of a series of five articles about preserving user sensitive settings.

INI-files are meant to retain settings between instances of your applications. Their structure is very simple, which limits their functionality.

This article explains the structure of ini files, and the basics of how to read and write them from Delphi.

Structure of ini files

Lets first have a look at the structure of ini-files. Basically, an ini file has a number of blocks, enclosed in square brackets, and every block has some settings.

Example: here is a part of my W2000 win.ini file:

[WinZip]

version=6.1-6.2

Note-1=This section is required only to install the optional WinZip Internet Browser Support build 0231.

Note-2=Removing this section of the win.ini will have no effect except preventing installation of WinZip Internet Browser Support build 0231.

win32_version=R6.3-7.0

[Solitaire]

Options=91

[MSUCE]

Advanced=0

CodePage=Unicode

Font=Arial

[MAPI 1.0 Time Zone]

Bias=0

StandardName=GMT Standard Time

StandardBias=0

StandardStart=00000A00050002000000000000000000

DaylightName=GMT Daylight Time

DaylightBias=ffffffc4

DaylightStart=00000300050001000000000000000000

ActiveTimeBias=0

We have blocks between square brackets, such as {WINZIP], [Solitaire], and [MAPI 1.0 Time Zone]. Winzip has 4 data items, version, Note-1, Note-2 and win32_version.

The data behind an item name can be alphabetical, numeric or boolean. Binary data is limited to those data which does no contains a #0 or CR/LF. Blank lines may be used between the blocks.

As you can see above, many applications use the win.ini file to store settings-information. You are free to choose the win.ini file. If you have just a few settings, this may be the right choice. Other applications should not suffer in any way. If you have more than one block of information, it is preferable to define your own ini file.

Writing ini-files from Delphi

Delphi provides us with a TIniFile object. This object is defined in the unit ini-files. Add this unit to your uses clause. Then create :

lIniFileVar := TIniFile.create(FileName);

You may or may not include a path with the filename. If you don't, windows will assume it must be created in the windows directory. This is the default. By using the ExtractFileDir(Application.Exename), you can easily create ini-files in the directory in which your application is created. Simply pass the entire path with the file name.

If the file already exists, windows will open it. If it does not, windows will create it.

The next thing you will want is to write some information to it. We will construct a small demo application. Start your Delphi, choose new application, and save your form as formDemoIniFile, and your project as DemoIniFile. Put a textbox, a SaveFile dialog and an OpenDialog component on your form. Next, drop two buttons on your form, and call them btnExit and btnOpenFile.

In the btnOpenFileClick event, write:

procedure TForm1.btnFileOpenClick(Sender: TObject);
var
  lIniFileVar: TIniFile;
begin
  OpenDialog1.Filter := 'Text files |*.txt|All files|*.*';
  if OpenDialog1.execute then
  begin
    edit1.text := OpenDialog1.FileName;
    lIniFileVar := TIniFile.create('DemoApp.ini');
    lIniFileVar.WriteString('OPENEDFILES', 'OPENDIALOG1', edit1.text);
    lIniFileVar.WriteString('OPENEDFILES', 'OPENDIALOG1LASTDIR',
      ExtractFileDir(edit1.text));
    lIniFileVar.free;
  end;
end;

lIniFileVar is a local variable in this routine of th type TIniFile. When we create it, we pass the filename, in this case DemoApp.ini. Next we use the WriteString method to write the contents of to the edit1.text to the inifile. We specify this string must be stored in the block OPENEDFILES and that the item name = OPENDIALOG1. next we also write the directory.

After we have run this program, the result might look:

[OPENEDFILES]

OPENDIALOG1=E:\program files\delforex\License.txt

OPENDIALOG1LASTDIR=E:\program files\delforex

Writing numeric data is essentially the same, and so is writing booleans.

Reading them from Delphi

Of course we gain nothing when we can write data but cann't read them. So we expand our example a bit with a few lines to read the previous data before we present the OpenFileDialog.

procedure TForm1.btnFileOpenClick(Sender: TObject);
var
  lIniFileVar: TIniFile;
begin
  // read old data and assign them to OpenFile dialog.
  lIniFileVar := TIniFile.create('DemoApp.ini');
  OpenDialog1.FileName := lIniFileVar.ReadString('OPENEDFILES', 'OPENDIALOG1', '');
  OpenDialog1.InitialDir := lIniFileVar.ReadString('OPENEDFILES',
                 'OPENDIALOG1LASTDIR', '');
  lIniFileVar.Free;
  OpenDialog1.Filter := 'Text files |*.txt|All files|*.*';
  // ask user to open file
  if OpenDialog1.execute then
  begin
    edit1.text := OpenDialog1.FileName;
    // Store new file data in ini file.
    lIniFileVar := TIniFile.create('DemoApp.ini');
    lIniFileVar.WriteString('OPENEDFILES', 'OPENDIALOG1', edit1.text);
    lIniFileVar.WriteString('OPENEDFILES', 'OPENDIALOG1LASTDIR',
      ExtractFileDir(edit1.text));
    lIniFileVar.free;
  end;
end;

Note that the ReadString Function requires a third argument, this is the default value. Note that one may use the ReadSectionValues (const Section: string; Strings: TStrings) method to read all values of an entire section.

Hacking delphi

There are some circumstances in which you might want to read an entire block (also called 'section'). If you wish to use this function, some Delphi hacking might be useful. By default, the buffer for the reading sections is 16K. You can upgrade this to 32K no problem.  

Simply start Delphi, open \Program Files\Borland\Delphi5\Source\Vcl\inifil.pas, and look for the ReadSection and ReadSections procedures. Both have a constant :

BufSize = 16384;

Change this constant to 32768 and you claim double the amount of memory.

When you study this unit, you will find that all methods boil down to usage of the windows WritePrivateProfileString and GetPrivateProfileString functions.

The unit has no WriteSectionValues procedure. Should you wish, it can be easily added.
    
procedure TCustomIniFile.WriteSectionValues(const Section:
  string; Strings: TStrings);
var
  KeyList: TStringList;
  i: Integer;
begin
  KeyList := TStringList.Create;
  for i := 0 to Strings.Count - 1 do
  begin
    WriteString(Section, Strings.Names[i],
      Strings.Values[Strings.Names[i]]);
  end;
end;

Alternative

There is an alternative for the usage of the TInifile object. Any TStringList has a LoadFromFile and SaveToFile method. Using the Values property, one could extract item values from them, and even change them. But as these methods do not adhere to the windows api's and their rules about file locations, this practice is not recommended. Also, as the Values property does not support usage of sections, this may lead to problems with duplicate item names.

Conclusion

You now know how to use ini-files. You should also be aware of its possibilities. As for its limitations: Don't try to store binary data. Neither store strings which contain a CR/LF, as your values can be just 1 line of  length..

How to play a video on program start

Problem/Question/Abstract:

I'm writing a program that plays an AVI when it starts and placed the mediaplayer.play command on the FormActivate event. The problem is that the movie starts playing before all objects have been painted and after all objects are painted the movie blinks. Is there a way to control that the movie starts after the form has been painted completely and not before?

Answer:

You could use e.g. a private variable of type boolean and a timer:

procedure TForm1.FormActivate(Sender: TObject);
begin
  if not AviPlayed then
    Timer1.Enabled := True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := False;
  {play your avi here}
  AviPlayed := True;
end;

How to write a number (integer, float etc.) to a stream

Problem/Question/Abstract:

How can I write a number (integer, float, etc.) to a stream? I am trying to save the contents of a TList to a TFileStream. First I have to save the count of the number of items in the list and save the count.

Answer:

var
  S: TMemoryStream;
  I: LongInt;
begin
  S := TMemoryStream.Create;
  try
    I := 1234;
    S.Write(I, SizeOf(I));
  finally
    S.Free;
  end;
end;

Closing Internet Explorer from Delphi

Problem/Question/Abstract:

My application has to close the IE. How can an application close the Internet Explorer or an Explorer window?

Answer:

The key is to post to the *right* window. Use the code below and it will close all instances of IE.

program Sample;

function CloseIEs(Wnd: HWnd; Form: TForm1): Boolean; export; stdcall;
var
  sCap: array[0..255] of char;
begin
  GetWindowText(Wnd, sCap, sizeof(sCap));
  if pos('Microsoft Internet Explorer', sCap) > 0 then
  begin
    PostMessage(Wnd, WM_CLOSE, 0, 0);
  end
  else
  begin
    // check by class name!
    GetClassName(Wnd, sCap, sizeof(sCap));
    if sCap = 'IEFrame' then
      PostMessage(Wnd, WM_CLOSE, 0, 0);
  end;

  CloseIEs := true; { next window, please }
end;

begin
  // close all hidden instances
  EnumWindows(@CloseIEs, 0);
end.

How to use the TMediaPlayer to record sound from a microphone

Problem/Question/Abstract:

I'm trying to use MediaPlayer to record sound into a wave file through a microphone. Can someone show me some simple code to do the recording?

Answer:

The TMediaPlayer can only open a wave file that has at least one byte of data in it. I found this out when I tried to create and open a wave file that was nothing but a wave header. The TMediaPlayer wouldn't do it. The following code creates a wave file with a single byte of data at the beginning. It is a bit of a kludge to do it this way, but it works. You need to add MMSYSTEM to the uses clause of any unit that uses this function.


function CreateNewWave(NewFileName: string): Boolean;
var
  DeviceID: Word;
  Return: LongInt;
  MciOpen: TMCI_Open_Parms;
  MciRecord: TMCI_Record_Parms;
  MciPlay: TMCI_Play_Parms;
  MciSave: TMCI_SaveParms;
  MCIResult: LongInt;
  Flags: Word;
  TempFileName: array[0..255] of char;
begin
  MediaPlayer.Close;
  StrPCopy(TempFileName, NewFileName);
  MciOpen.lpstrDeviceType := 'waveaudio';
  MciOpen.lpstrElementName := '';
  Flags := Mci_Open_Element or Mci_Open_Type;
  MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
  DeviceID := MciOpen.wDeviceId;
  MciRecord.dwTo := 1;
  Flags := Mci_To or Mci_Wait;
  MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord));
  mciPlay.dwFrom := 0;
  Flags := Mci_From or Mci_Wait;
  MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
  mciSave.lpfileName := TempFilename;
  Flags := MCI_Save_File or Mci_Wait;
  MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
  Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0;
end;

Show a secondary form without the main form

Problem/Question/Abstract:

How do I make it so that only the form I select comes to the top (i.e. without the main form)?

Answer:

Try this in any secondary window that you don't want dragging the program along:

{ ... }
private
{ Private declarations }

procedure CreateParams(var Params: TCreateParams); override;
{ ... }

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.WndParent := GetDesktopWindow;
end;

By setting the form's parent window handle to the desktop, you remove the link that would normally force the whole application to come to the top when this form comes to the top.

Check if scrollbars are present in a TListView

Problem/Question/Abstract:

Is there a way to determine if the scrollbars are present with a TListView component? If so, is it possible to be specific enough to determine which one is present, i.e vertical scroll or horizontal scroll?

Answer:

Yes to both:

{Function WindowScrollbars

Parameters:
Window handle of control or window to check.

Returns:
The TScrollstyle describing the current scrollbar configuration, either ssNone, ssHorizontal, ssVertical, ssBoth.

Description:
Checks the WS_VSCROLL and WS_HSCROLL style bits of the window style.

Error Conditions: none
Created: 21.10.99 by P. Below}

function WindowScrollbars(wnd: HWND): TScrollStyle;
var
  styleflags: DWORD;
begin
  styleflags := GetWindowLong(wnd, GWL_STYLE) and (WS_VSCROLL or WS_HSCROLL);
  case styleflags of
    0: Result := ssNone;
    WS_VSCROLL: Result := ssVertical;
    WS_HSCROLL: Result := ssHorizontal;
  else
    Result := ssBoth;
  end;
end;

Call with listview.handle as parameter.

How to implement your own double buffering

Problem/Question/Abstract:

In order to give a control the appearance of being "transparent", in the WM_EraseBkgnd message processing section I'm invalidating the rectangle the control covers in the parent control's context and then having the parent control repaint itself in the rectangle that's hidden behind the control. However, this doesn't work when the control's DoubleBuffer property is set to true. Does anyone know how to get this working with double buffered controls?

Answer:

VCL double-buffering is ineffective and limited. If you need double-buffering, you will need to implement it yourself. To do this process the WM_PAINT message and do something like this:



1) Do your own effective double-buffering:


procedure TCustomElPanel.WMPaint(var Msg: TWMPaint);
var
  DC, MemDC: HDC;
  MemBitmap, OldBitmap: HBITMAP;
  PS: TPaintStruct;
  R: TRect;
  ARgn: HRGN;
begin
  if (Msg.DC <> 0) then
    PaintHandler(Msg)
  else
  begin
    DC := GetDC(0);
    MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);
    ReleaseDC(0, DC);
    MemDC := CreateCompatibleDC(0);
    OldBitmap := SelectObject(MemDC, MemBitmap);
    try
      DC := BeginPaint(Handle, PS);
      GetClipBox(DC, R);
      if IsRectEmpty(R) then
        R := ClientRect
      else
      begin
        InflateRect(R, 1, 1);
      end;
      with R do
        ARgn := CreateRectRgn(Left, Top, right, Bottom);
      SelectClipRgn(MemDC, ARgn);
      Perform(WM_ERASEBKGND, MemDC, MemDC);
      Msg.DC := MemDC;
      WMPaint(Msg);
      SelectClipRgn(MemDC, 0);
      DeleteObject(ARgn);
      Msg.DC := 0;
      with R do
        BitBlt(DC, Left, Top, Right, Bottom, MemDC, Left, Top, SRCCOPY);
      EndPaint(Handle, PS);
    finally
      SelectObject(MemDC, OldBitmap);
      DeleteDC(MemDC);
      DeleteObject(MemBitmap);
    end;
  end;
end;


2) When painting, ask your parent to draw on your canvas or do the following:


{ ... }
if Transparent then
begin
  GetClipBox(Canvas.Handle, Rect);
  OffsetRect(Rect, Left, Top);
  RedrawWindow(Parent.Handle, @Rect, 0, RDW_ERASE or RDW_INVALIDATE or
    RDW_NOCHILDREN or RDW_UPDATENOW);
  begin
    OffsetRect(Rect, -Left, -Top);
    DC := GetDC(Handle);
    bitblt(Canvas.Handle, 0, 0, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
      DC, Rect.Left, Rect.Top, SRCCOPY);
    ReleaseDC(Handle, DC);
  end;
end;
{ ... }