How to check if Active Desktop is enabled

Problem/Question/Abstract:

How to check if Active Desktop is enabled

Answer:

uses
  ComObj, ShlObj, ActiveX;

{Check if Active Desktop is enabled - Option 1}

function IsActiveDeskTopOn: Boolean;
var
  h: HWND;
begin
  h := FindWindow('Progman', nil);
  h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil);
  h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil);
  Result := h <> 0;
end;

{Check if Active Desktop is enabled - Option 2}

function IsActiveDesktopEnable: Boolean;
const
  CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
  ActiveDesk: IActiveDesktop;
  ComponentsOpt: TComponentsOpt;
  hr: HRESULT;
  dwReserved: DWORD;
begin
  ZeroMemory(@ComponentsOpt, SizeOf(TComponentsOpt));
  ComponentsOpt.dwSize := SizeOf(TComponentsOpt);
  hr := CoCreateInstance(CLSID_ActiveDesktop, nil, CLSCTX_INPROC_SERVER,
    CLSID_ActiveDesktop, ActiveDesk);
  if SUCCEEDED(hr) then
  begin
    hr := ActiveDesk.GetDesktopItemOptions(ComponentsOpt, dwReserved);
    {ActiveDesk._Release;}
  end;
  Result := ComponentsOpt.fActiveDesktop;
end;


And here is how to activate the Active Desktop:


procedure TForm1.Button1Click(Sender: TObject);
const
  CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
  ActiveDesk: IActiveDesktop;
  ComponentsOpt: TComponentsOpt;
begin
  ActiveDesk := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
  with ActiveDesk do
  begin
    ComponentsOpt.dwSize := SizeOf(ComponentsOpt);
    GetDesktopItemOptions(ComponentsOpt, 0);
    ComponentsOpt.fActiveDesktop := True;
    SetDesktopItemOptions(ComponentsOpt, 0);
    ApplyChanges(AD_APPLY_ALL);
  end;
end;

How to print a TScrollBox that contains controls generated at runtime

Problem/Question/Abstract:

How to print a TScrollBox that contains controls generated at runtime

Answer:

If this is some kind of custom control you developed yourself teach it to print itself. In fact it may be able to do that already using the PaintTo method. The main problem here is scaling. If your control uses device units (pixels) as measures instead of some device-independent unit like mm or inches you will need to scale the printer.canvas before you pass it to a controls PaintTo method. Scaling the printer canvas to the screen resolution is pretty straightforward. Here is an older example that you can tailor to your needs.

Print all of a forms client area, even if parts are not visible. The form will clip the output to the visible area if you try to output it to a canvas using using the forms paintto method. But one can print the controls on it individually and that is not clipped:

procedure TForm1.Button1Click(Sender: TObject);
var
  c: TControl;
  i: Integer;
  topX, topY: Integer;
begin
  printer.begindoc;
  try
    { Scale printer to screen resolution. }
    SetMapMode(printer.canvas.handle, MM_ANISOTROPIC);
    SetWindowExtEx(printer.canvas.handle, GetDeviceCaps(canvas.handle, LOGPIXELSX),
      GetDeviceCaps(canvas.handle, LOGPIXELSY), nil);
    SetViewportExtEx(printer.canvas.handle, GetDeviceCaps(printer.canvas.handle,                LOGPIXELSX),
      GetDeviceCaps(printer.canvas.handle, LOGPIXELSY), nil);
    topX := 10;
    topY := 10;
    for i := 0 to controlcount - 1 do
    begin
      c := controls[i];
      if c is TWinControl then
        TWinControl(c).paintto(printer.canvas.handle, c.left + topX, c.top + topy);
    end;
  finally
    printer.enddoc;
  end;
end;

The problem here is that this only prints TWinControl descendents, if you have TLabels or TImages on the form they are not printed. The solution is to put everything on the form onto a single top level TPanel. This panel is *not* aligned to alClient, it has its left and top set to 0 and its width and height is such that all controls fit on it. The code above then prints this panel unclipped and the panel prints any non-TWinControls on it.

The usual caveats for PaintTo apply: not all controls will implement this method properly (a Windows limitation). Bitmaps on the form may not appear on the printer if the printer is not able to print device-dependent bitmaps for the screen. It may be advisable to first paint the form to a properly sized tBitmaps canvas (you can omit all the scaling stuff for that since the bitmap resolution is the same as the screens) and then print the bitmap as a device independent bitmap using StretchDIBits.

How to change property values (RTTI)

Problem/Question/Abstract:

I use setpropvalue() function to set property values. It works fine if I set properties that are on first level (i.e.. button1.caption, button1.name,..), but it fails if I want to set properties like button1.font.name or radiogroup.items.text.

Answer:

function GetProperty(AControl: TPersistent; AProperty: string): PPropInfo;
var
  i: Integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  propInfo: PPropInfo;
begin
  PropInfo := GetProperty(Button1.Font, 'Name');
  if PropInfo <> nil then
    SetStrProp(Button1.Font, PropInfo, 'Arial');
end;

How to communicate with a com port through RS232

Problem/Question/Abstract:

I want to develop a device that communicates through RS232 with the Com1 port. I know the port is connected to IRQ4 and I know the IO address of the 8250 status and data registers. I know how to do this mission in DOS (interrupt vector), but what I do not know is how to do something like this with Window 98 system and Delphi as a programming platform.

Answer:

The DOS solution is not recommended and will not work under NT anyway. The following unit has a class for the RS232 communication:


unit ComPort;

interface

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

type
  TComPort = class(TObject)
  private
    ComID, ComError: Integer;
    DcbOld: TDCB;
    CommTimeoutsOld: TCommTimeouts;
  protected
  public
    function Open(PortNo: integer): boolean;
    procedure Close;
    function Config(Baudrate: DWORD; ByteSize, StopBits, Parity: Byte): boolean;
    function ReadBlock(var Ch: array of char; BlockSize: dword): integer;
    function ReadChar(var Ch: char): boolean;
    function WriteBlock(var Ch: array of char; BlockSize: dword): boolean;
    function WriteChar(Ch: char): boolean;
    procedure Purge;
    function Error: integer;
    constructor Create;
  published
  end;

const
  cpReadError = 1;
  cpWriteError = 2;
  cpOpenError = 3;

implementation

constructor TComPort.Create;
begin
  inherited Create;
  ComID := -1;
end;

function TComPort.Open(PortNo: integer): boolean;
var
  CommTimeouts: TCommTimeouts;
  Port: string;
begin
  Port := 'COM' + IntToStr(PortNo);
  ComID := CreateFile(pChar(Port), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
  if ComID <> -1 then
  begin
    GetCommState(ComID, DcbOld);
    GetCommTimeouts(ComID, CommTimeoutsOld);
    CommTimeouts.ReadIntervalTimeout := 1;
    CommTimeouts.ReadTotalTimeoutMultiplier := 1;
    CommTimeouts.ReadTotalTimeoutConstant := 1;
    CommTimeouts.WriteTotalTimeoutMultiplier := 10;
    CommTimeouts.WriteTotalTimeoutConstant := 10;
    SetCommTimeouts(ComID, CommTimeouts);
    ComError := 0;
  end
  else
    ComError := cpOpenError;
  Result := (ComID <> -1)
end;

procedure TComPort.Close;
begin
  if ComID <> -1 then
  begin
    SetCommState(ComID, DcbOld);
    SetCommTimeouts(ComID, CommTimeoutsOld);
    CloseHandle(ComID);
  end;
  ComID := -1;
end;

function TComPort.Config(Baudrate: DWORD; ByteSize, StopBits, Parity: Byte): boolean;
var
  Dcb: TDCB;
begin
  if ComID <> -1 then
  begin
    GetCommState(ComID, Dcb);
    Dcb.Baudrate := Baudrate;
    Dcb.ByteSize := ByteSize;
    Dcb.StopBits := StopBits;
    Dcb.Parity := Parity;
    SetCommState(ComID, Dcb);
  end
  else
    ComError := cpOpenError;
  Result := (ComID <> -1)
end;

function TComPort.ReadBlock(var Ch: array of char; BlockSize: dword): integer;
var
  rdBlockSize: dword;
begin
  Result := 0;
  if ComID <> -1 then
  begin
    rdBlockSize := BlockSize;
    if not ReadFile(ComID, Ch, BlockSize, rdBlockSize, nil) then
    begin
      GetLastError;
      ComError := cpReadError;
    end
    else
      Result := rdBlockSize;
  end
  else
    ComError := cpOpenError;
end;

function TComPort.ReadChar(var Ch: char): boolean;
var
  BlockSize: dword;
begin
  Result := False;
  if ComID <> -1 then
  begin
    if not ReadFile(ComID, Ch, 1, BlockSize, nil) then
    begin
      GetLastError;
      ComError := cpReadError;
    end
    else
      Result := (BlockSize = 1);
  end
  else
    ComError := cpOpenError;
end;

function TComPort.WriteBlock(var Ch: array of char; BlockSize: dword): boolean;
var
  W: dword;
begin
  Result := False;
  if ComID <> -1 then
  begin
    if not WriteFile(ComID, Ch, BlockSize, W, nil) then
    begin
      GetLastError;
      ComError := cpWriteError;
    end
    else
      Result := (BlockSize = W)
  end
  else
    ComError := cpOpenError;
end;

function TComPort.WriteChar(Ch: char): boolean;
var
  W: dword;
begin
  Result := False;
  if ComID <> -1 then
  begin
    if not WriteFile(ComID, Ch, 1, W, nil) then
    begin
      GetLastError;
      ComError := cpWriteError;
    end
    else
      Result := (W = 1)
  end
  else
    ComError := cpOpenError;
end;

procedure TComPort.Purge;
begin
  if ComID <> -1 then
  begin
    PurgeComm(ComID, Purge_TXABORT);
    PurgeComm(ComID, Purge_RXABORT);
    PurgeComm(ComID, Purge_TXCLEAR);
    PurgeComm(ComID, Purge_RXCLEAR);
  end
  else
    ComError := cpOpenError;
end;

function TComPort.Error: integer;
begin
  Result := ComError;
  ComError := 0;
end;

end.


And this is how you use this class:


{ ... }
var
  ComPort: TComPort;

In the Form1.OnCreate event:


ComPort := TComPort.Create;
ComPort.Open(1); {for COM1}


So now you can use ComPort.Config (see in Win32 API SetCommState for the Config parameter)


ComPort.WriteBlock
ComPort.WriteChar
ComPort.ReadBlock
ComPort.ReadChar

etc.


In the Form1.OnClose event:


ComPort.Close;
ComPort.Free;

Hiding/showing the Windows taskbar

Problem/Question/Abstract:

Hiding/showing the Windows taskbar

Answer:

Use these functions to hide or show the Windows taskbar programmatically from your Delphi application:


procedure hideTaskbar;
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_HIDE); // This hides the taskbar
end;

procedure showTaskbar;
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_RESTORE); // This restores the taskbar
end;

How can i reboot my windows

Problem/Question/Abstract:

How can i reboot my windows?

Answer:

To Reboot your computer you just have to insert the next code:

ExitWindowsEx(EWX_FORCE and EWX_REBOOT);

This line of code while cause a LogOff in Windows 2000 and Windows XP.

If you need to ShutDown the line of code is:

ExitWindowsEx(EWX_FORCE and EWX_SHUTDOWN);

For more informaction about this, just write ExitWindowsEx in your program and then press F1 and will appear the help related with this function.

Convert a Delphi form (from file) to text and vice versa

Problem/Question/Abstract:

Convert your Delphi form from .dfm format to text and vice versa

Answer:

use this function to convert:

  Example (DFM->TXT): ConvertFormToText('unit1.dfm');
  Example (TXT->DFM): ConvertTextToForm('unit1.txt');

uses
  SysUtils;

function ConvertFormToText(SourceFileName: string): boolean;
var
  InputStream, OutputStream: TFileStream;
  DestFileName: string;
begin
  result := true;

  { change the file extension to .txt }
  DestFileName := ChangeFileExt(SourceFileName, '.txt');

  { Create a file stream for the specified file }
  InputStream := TFileStream.Create(SourceFileName, fmOpenRead);
  OutputStream := TFileStream.Create(DestFileName, fmCreate);

  { convert }
  try
    try
      ObjectResourceToText(InputStream, OutputStream);
    except
      on EStreamError do
        Result := False;
    end
  finally
    { free memory }
    InputStream.Free;
    OutputStream.Free;
  end;
end;

function ConvertTextToForm(SourceFileName: string): boolean;
var
  InputStream, OutputStream: TFileStream;
  DestFileName: string;
begin
  result := true;

  DestFileName := ChangeFileExt(SourceFileName, '.dfm');

  InputStream := TFileStream.Create(SourceFileName, fmOpenRead);
  OutputStream := TFileStream.Create(DestFileName, fmCreate);

  try
    try
      ObjectTextToResource(InputStream, OutputStream);
    except
      on EStreamError do
        result := false;
    end
  finally
    InputStream.Free;
    OutputStream.Free;
  end;
end;

How to implement string pattern matching with wildcards

Problem/Question/Abstract:

How to implement string pattern matching with wildcards

Answer:

There are many times when you need to compare two strings, but want to use wild cards in the match - all last names that begin with 'St', etc.

This function takes two strings and compares them. The first string can be anything, but should not contain pattern characters (* or ?). The pattern string can have as many of these pattern characters as you want. For example: MatchStrings('David Stidolph','*St*') would return True.}

function MatchStrings(source, pattern: string): Boolean;
var
  pSource: array[0..255] of Char;
  pPattern: array[0..255] of Char;

  function MatchPattern(element, pattern: PChar): Boolean;

    function IsPatternWild(pattern: PChar): Boolean;
    var
      t: Integer;
    begin
      Result := StrScan(pattern, ' * ') <> nil;
      if not Result then
        Result := StrScan(pattern, ' ? ') <> nil;
    end;

  begin
    if 0 = StrComp(pattern, ' * ') then
      Result := True
    else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
      Result := False
    else if element^ = Chr(0) then
      Result := True
    else
    begin
      case pattern^ of
        ' * ':
          if MatchPattern(element, @pattern[1]) then
            Result := True
          else
            Result := MatchPattern(@element[1], pattern);
        ' ? ':
          Result := MatchPattern(@element[1], @pattern[1]);
      else
        if element^ = pattern^ then
          Result := MatchPattern(@element[1], @pattern[1])
        else
          Result := False;
      end;
    end;
  end;

begin
  StrPCopy(pSource, source);
  StrPCopy(pPattern, pattern);
  Result := MatchPattern(pSource, pPattern);
end;

How to map a variant OLEObject to an interface

Problem/Question/Abstract:

There seems to be no way to map the variant OLEObject to an interface (in our case Word 2000) or even cast it so at design time.

Answer:

Yes there is. The OleContainer's OleObject property holds the document as an IDispatch, and you can just cast to the interface you want. For example:

{ ... }
Doc: _Document;
{ ... }

OleContainer1.CreateObjectFromFile(Path, False);
OleContainer1.DoVerb(ovShow);
Doc := IDispatch(OleContainer1.OleObject) as _Document;

How to detect the regional settings of a system

Problem/Question/Abstract:

How to detect the regional settings of a system

Answer:

Here is some sample code to get the language's abbreviated name, e.g.: ENU.

{ ... }
var
  Buffer: PChar;
  Size: integer;
begin
  Size := GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SABBREVLANGNAME, nil, 0);
  GetMem(Buffer, Size);
  try
    GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SABBREVLANGNAME, Buffer, Size);
    Result := string(Buffer);
  finally
    FreeMem(Buffer);
  end;
end;

This code gets the current Currency Symbol from Windows' regional settings:

function GetCurrencySymbol: string;
var
  Res: Cardinal;
begin
  Res := GetLocaleInfo(GetUserDefaultLCID, LOCALE_SCURRENCY, nil, 0);
  SetLength(Result, Res);
  Res := GetLocaleInfo(GetUserDefaultLCID, LOCALE_SMONDECIMALSEP, PChar(Result), Res);
  if Res = 0 then
    RaiseLastOSError;
end;

Paint a TBitmap in disabled state

Problem/Question/Abstract:

How can I make an image to appear enabled and disabled (i.e going from original to disabled-grey and back)? I know that TImage doesn't support this feature, so how would I implement this?

Answer:

Everyone from you saw that standard TSpeedButton allow to show a loaded glyph in "disabled" state when your original glyph will be converted into gray-scheme.

Sometimes to create similar bitmap is useful not only for TSpeedButton.

You can use the next my CreateDisabledBitmap procedure where such "disabled" bitmap (Destination parameter) will be created from your original bitmap (Source).

procedure CreateDisabledBitmap(Source, Destination: TBitmap);
const
  ROP_DSPDxax = $00E20746;
var
  DDB, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect: TRect;
begin
  IWidth := Source.Width;
  IHeight := Source.Height;
  Destination.Width := IWidth;
  Destination.Height := IHeight;
  IRect := Rect(0, 0, IWidth, IHeight);
  Destination.Canvas.Brush.Color := clBtnFace;
  Destination.Palette := CopyPalette(Source.Palette);
  MonoBmp := nil;
  DDB := nil;
  try
    MonoBmp := TBitmap.Create;
    DDB := TBitmap.Create;
    DDB.Assign(Source);
    DDB.HandleType := bmDDB;
    { Create a disabled version }
    with MonoBmp do
    begin
      Assign(Source);
      HandleType := bmDDB;
      Canvas.Brush.Color := clBlack;
      Width := IWidth;
      if Monochrome then
      begin
        Canvas.Font.Color := clWhite;
        Monochrome := False;
        Canvas.Brush.Color := clWhite;
      end;
      Monochrome := True;
    end;
    with Destination.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(IRect);
      Brush.Color := clBtnHighlight;
      SetTextColor(Handle, clBlack);
      SetBkColor(Handle, clWhite);
      BitBlt(Handle, 1, 1, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
      Brush.Color := clBtnShadow;
      SetTextColor(Handle, clBlack);
      SetBkColor(Handle, clWhite);
      BitBlt(Handle, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
    end;
  finally
    DDB.Free;
    MonoBmp.Free;
  end;
  Source.Dormant;
end;

Sample of use:

procedure TfrmMain.ButtonClick(Sender: TObject);
var
  Destination: TBitmap;
begin
  Destination := TBitmap.Create;
  try
    CreateDisabledBitmap(Image1.Picture.Bitmap, Destination);
    Image2.Picture.Bitmap.Assign(Destination);
  finally
    Destination.Free
  end
end;

where Image1 is TImage where you have an original bitmap and TImage2 will a container for created disabled bitmap.

How to play system sounds

Problem/Question/Abstract:

Is there any way to play system default sounds (like MessageBeep(mb_IconError) or mb_IconQuestion or these)? I need a way to play all the default sounds set in the system control (e.g. "new mail", "start windows" etc.).

Answer:

If you want to play the sound associated with "Empty Recycle Bin" then call the following procedure. Using the Key Name -> PlayRegisteredSound("EmptyRecycleBin") and Window's takes care of the rest.


procedure PlayRegisteredSound(SoundKeyName: string);
begin
  { call win32 api procedure PlaySound() }
  PlaySound(PChar(SoundKeyName), 0, SND_APPLICATION or SND_NODEFAULT or
    SND_ASYNC or SND_NOWAIT);
end;


Follow the RegKey by examining the keys beneath HKEY_CURRENT_USER\AppEvents\Schemes. Here you'll find where the wav files are registered and changed by the Sounds applet in the Control Panel.

Copy a file with or without a progressbar

Problem/Question/Abstract:

How to COPY a file with or without a progressbar

Answer:

function FileCopy(const SourceFile, TargetFile: string): Boolean; overload;
function FileCopy(const SourceFile, TargetFile: string; PB: TProgressBar): Boolean;
  overload;

function FileCopy(const SourceFile, TargetFile: string): Boolean;
begin
  Result := FileCopy(SourceFile, TargetFile, nil);
end;

function FileCopy(const SourceFile, TargetFile: string; PB: TProgressBar):
  Boolean;
const
  BlockSize = 1024 * 16;
var
  FSource, FTarget: Integer;
  BRead, Bwrite: Word;
  Buffer: Pointer;
begin
  Result := False;

  FSource := FileOpen(SourceFile, fmOpenRead + fmShareDenyNone); { Open Source }

  if FSource >= 0 then
  try
    if Assigned(PB) then
    begin
      PB.Position := 0;
      pb.Min := 0;
      pb.Max := (FileSeek(FSource, 0, 2));
      if (pb.Max > 2048) then
        pb.Step := pb.Max div 2048
      else
        pb.Step := pb.Max;
      FileSeek(FSource, 0, 0);
    end;
    FTarget := FileCreate(TargetFile); { Open Target }
    try
      getmem(Buffer, BlockSize);
      try
        FileSeek(FSource, 0, soFromBeginning);
        repeat

          BRead := FileRead(FSource, Buffer^, BlockSize);

          if assigned(PB) then
            PB.StepIt;

          BWrite := FileWrite(FTarget, Buffer^, Bread);

          if assigned(PB) then
            PB.StepIt;

        until (Bread = 0) or (Bread <> BWrite);
        if Bread = Bwrite then
        begin
          Result := True;
          if assigned(PB) then
            PB.Position := PB.Max;
        end;
      finally
        freemem(Buffer, BlockSize);
      end;
      FileSetDate(FTarget, FileGetDate(FSource));
    finally
      FileClose(FTarget);
    end;
  finally
    FileClose(FSource);
  end;
end;

How to reach a graphic field without using a TDBImage

Problem/Question/Abstract:

How to reach a graphic field without using a TDBImage

Answer:

var
  Pic: TPicture;
begin
  Pic := TPicture.Create;
  dm.tbDeviceTypes.first;
  while not dm.tbDeviceTypes.EOF do
  begin
    Pic.Assign(dm.tbDeviceTypesFreePic);
    ImageList1.AddMasked(Pic.BitMap, ClWhite);
    dm.tbDeviceTypes.next;
  end;
end;

How can I set the bar color of a TProgressbar?

Problem/Question/Abstract:

This code will show you, how you can set the bar color of a TProgressbar.

Answer:

procedure SetBarColor(Component: TProgressBar; Color: TColor);
begin
  SendMessage(Component.Handle, 1033, 0, Color);
end;

How to retrieve all available TBrushStyle values as a list of strings

Problem/Question/Abstract:

I need to get a list of strings (like a StringList) with the possible values for a TBrushStyle property (bsSolid, bsClear, bsHorizontal, for example). I want to build a ComboBox with this options. How can I set the property Items of my ComboBox directly with all the values from the enumerated type TBrushStyle? My ComboBox will be alike the Property Editor for this type.

Answer:

You can use runtime type information (RTTI) to do that. Below is an example:

uses
  {...}, TypInfo

procedure BrushStylesAsStrings(AList: TStrings);
var
  a: integer;
  pInfo: PTypeInfo;
  pEnum: PTypeData;
begin
  AList.Clear;
  pInfo := PTypeInfo(TypeInfo(TBrushStyle));
  pEnum := GetTypeData(pInfo);
  with pEnum^ do
  begin
    for a := MinValue to MaxValue do
      AList.Add(GetEnumName(pInfo, a));
  end;
end;

Read the content of an Excel object embedded in a Word document

Problem/Question/Abstract:

I have an Excel object in a Word document. I want to read the content of the Excel object from my Delphi program. How can I do that?

Answer:

{ ... }
var
  AWordApplication: WordApplication;
  AWordDocument: WordDocument;
  AWorkBook: ExcelWorkBook;
  AWorkSheet: ExcelWorkSheet;
  AInlineShape: InlineShape;
  AFileName: OleVariant;
  TrueParam: OleVariant;
begin
  AWordApplication := CoWordApplication.Create;
  try
    FalseParam := False;
    AFileName := 'c:\wordexcel.doc';
    AWordDocument := AWordApplication.Documents.Open(AFileName, EmptyParam,
      EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    AInlineShape := AWordDocument.InlineShapes.Item(1);
    AInlineShape.Activate;
    AWorkBook := AWordDocument.InlineShapes.Item(1).OLEFormat.Object_ as
      ExcelWorkBook;
    AWorkSheet := AWorkBook.ActiveSheet as ExcelWorkSheet;
    ShowMessage(AWorkSheet.Cells.Item[2, 1].Text);
  finally
    AWordApplication.Quit(FalseParam, EmptyParam, EmptyParam);
    AWordApplication := nil;
    AWordDocument := nil;
  end;
end;

How to check if a drive is ready

Problem/Question/Abstract:

How can I check if there is a disk in the "A" drive without an error message box telling you that it is not ready?

Answer:

The following function accepts a drive letter as a parameter, and it will return a boolean value that indicates whether or not there is a disk in the drive.


function DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  {make it upper case}
  if Drive in ['a'..'z'] then
    Dec(Drive, $20);
  {make sure it's a letter}
  if not (Drive in ['A'..'Z']) then
    raise EConvertError.Create('Not a valid drive ID');
  {turn off critical errors}
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    { drive 1 = a, 2 = b, 3 = c, etc.}
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
  finally
    {restore old error mode}
    SetErrorMode(ErrorMode);
  end;
end;

The future of the BDE

Problem/Question/Abstract:

After Borland's official announcement regarding the future of the BDE, I contacted (and was contacted by) many Delphi developers who are currently using the BDE to learn about their future plans regarding data access...

Answer:

After Borland's official announcement regarding the future of the BDE, I contacted (and was contacted by) many Delphi developers who are currently using the BDE to learn about their future plans regarding data access.

For local databases, the BDE will keep being used, although a discrete minority are seriously considering switching to a BDE alternative in the short term (mainly Interbase accessed thru IBX or dbExpress, and third-party data access components).

For server databases, the scenario changes radically. Among those who are still using previous Delphi versions, many are not likely to upgrade, so they'll keep using the BDE + SQL Links all they can, while almost all the rest are considering mainly dbExpress, ADO and ADO.Net, but developers showed their concern about these alternatives:

dbExpress is not as "universal" as SQL Links, meaning there are missing drivers for some important database servers (like Microsoft SQL Server). About dbExpress being faster than the BDE, this is not true for small queries beause there's no caching mechanism (since there is no front layer like the BDE), so the metadata gets downloaded in every query. I'd like to credit Vasilis Devletoglou for sharing his findings about the inner workings of dbExpress with us. Finally, when one used a technology for many years, sometimes it's a bit difficult not be a bit conservative and consider new technologies as "beta". We all know dbExpress arrived here to stay, but many developers percieve it's still "green" and needs further development.

ADO and ADO.Net don't conform the expectations of Delphi programmers in performance and/or features, and it can't be ignored the fact that most programmers would rather prefer to use a Borland solution.

In conclusion, the only ones that are happy here seem to be those who switched to a BDE alternative some time ago... :-)


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

How to create a TPanel with scrollbars

Problem/Question/Abstract:

I want to create a component that has scrollbars (vertical/ horizontal). I tried to get the tricks from TCustomGrid but it doesn't work when I try to set a range/ position value to one of the scrollbars.

Answer:

This example uses an interposer class for convenience (mine, I just wanted to avoid the hassle of creating and installing a proper component for this example) but you should be able to adapt it for a proper component.

{ Example for fitting a panel with scrollbars }

unit Unit1;

interface

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

type
  TPanel = class(Extctrls.TPanel)
  private
    procedure WMVScroll(var msg: TWMSCROLL); message WM_VSCROLL;
    procedure WMHScroll(var msg: TWMSCROLL); message WM_HSCROLL;
    procedure WMGetDlgCode(var msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
  protected
    procedure CreateParams(var params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  end;

  TForm1 = class(TForm)
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TPanel }

procedure TPanel.CreateParams(var params: TCreateParams);
begin
  inherited;
  params.Style := params.Style or WS_VSCROLL or WS_HSCROLL;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  si: TScrollInfo;
begin
  si.cbSize := Sizeof(TScrollInfo);
  si.fMask := SIF_ALL or SIF_DISABLENOSCROLL;
  si.nMin := 0;
  si.nMax := 3 * panel1.clientheight;
  si.nPage := panel1.clientheight div 2;
  si.nPos := 0;
  SetScrollInfo(panel1.handle, SB_VERT, si, true);
  si.nMax := 2 * panel1.clientwidth;
  si.nPage := panel1.clientwidth div 2;
  SetScrollInfo(panel1.handle, SB_HORZ, si, true);
end;

procedure TPanel.HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
var
  si: TScrollInfo;
begin
  msg.result := 0;
  si.cbSize := Sizeof(TscrollInfo);
  si.fMask := SIF_ALL;
  GetScrollInfo(Handle, bar, si);
  si.fMask := SIF_POS;
  { For simplicities sake we use 1/10 of the page size as small scroll
         increment and the page size as large scroll increment }
  case msg.ScrollCode of
    SB_TOP: si.nPos := si.nMin;
    SB_BOTTOM: si.nPos := si.nMax;
    SB_LINEUP: Dec(si.nPos, si.nPage div 10);
    SB_LINEDOWN: Inc(si.nPos, si.nPage div 10);
    SB_PAGEUP: Dec(si.nPos, si.nPage);
    SB_PAGEDOWN: Inc(si.nPos, si.nPage);
    SB_THUMBTRACK, SB_THUMBPOSITION: si.nPos := msg.Pos;
    SB_ENDSCROLL: Exit;
  end;
  si.fMask := SIF_POS;
  if si.nPos < si.nMin then
    si.nPos := si.nMin;
  if si.nPos > si.nMax then
    si.nPos := si.nMax;
  SetScrollInfo(Handle, bar, si, true);
  { Fire a scroll notification off here to allow client to scroll content of panel }
end;

procedure TPanel.KeyDown(var Key: Word; Shift: TShiftState);

  procedure Scroll(scrollcode, message: Cardinal);
  begin
    Perform(message, scrollcode, 0);
  end;

const
  scrollkind: array[Boolean] of Cardinal = (WM_VSCROLL, WM_HSCROLL);
begin
  inherited;
  { Ignoring shift state for arrow keys here for simplicities sake }
  case Key of
    VK_UP: Scroll(SB_LINEUP, WM_VSCROLL);
    VK_LEFT: Scroll(SB_LINEUP, WM_HSCROLL);
    VK_DOWN: Scroll(SB_LINEDOWN, WM_VSCROLL);
    VK_RIGHT: Scroll(SB_LINEDOWN, WM_HSCROLL);
    VK_NEXT: Scroll(SB_PAGEDOWN, scrollkind[ssCtrl in Shift]);
    VK_PRIOR: Scroll(SB_PAGEUP, scrollkind[ssCtrl in Shift]);
    VK_HOME: Scroll(SB_TOP, scrollkind[ssCtrl in Shift]);
    VK_END: Scroll(SB_BOTTOM, scrollkind[ssCtrl in Shift]);
  end;
  Key := 0;
end;

procedure TPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if (Button = mbLeft) and CanFocus and not Focused then
    SetFocus;
end;

procedure TPanel.WMGetDlgCode(var msg: TWMGetDlgCode);
begin
  msg.result := DLGC_WANTARROWS;
end;

procedure TPanel.WMHScroll(var msg: TWMSCROLL);
begin
  HandleScrollbar(msg, SB_HORZ);
end;

procedure TPanel.WMVScroll(var msg: TWMSCROLL);
begin
  HandleScrollbar(msg, SB_VERT);
end;

end.

How to force a form to stay iconized

Problem/Question/Abstract:

How to force a form to stay iconized

Answer:

If your application should be iconized from the beginning, set the for property WindowState to wsMinimized.

To keep a form iconized (and prevent a restore), add the following handler to your form class definition:


// e.g. the private section

procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;

implementation

// ..

procedure TForm1.WMQueryOpen(var Msg: TWMQueryOpen);
begin
  Msg.Result := 0;
end;

Draw a grid on a TPaintBox

Problem/Question/Abstract:

How to draw a grid on a TPaintBox

Answer:

procedure TForm1.DrawPaintBoxGrid(distance: Integer);
var
  xpos, ypos: Integer;
begin
  PaintBox1.Canvas.Brush.Color := clBlack;
  ypos := 0;
  xpos := 0;
  while ypos < PaintBox1.Height do
  begin
    ypos := ypos + distance;
    PaintBox1.Canvas.MoveTo(0, ypos);
    PaintBox1.Canvas.LineTo(PaintBox1.Width, ypos);
    while xpos < PaintBox1.Width do
    begin
      xpos := xpos + distance;
      PaintBox1.Canvas.MoveTo(xpos, 0);
      PaintBox1.Canvas.LineTo(xpos, PaintBox1.Height);
    end;
  end;
end;

Make a TPanel look like the title bar of a window

Problem/Question/Abstract:

I have a good reason why I cannot use forms. So as an alternative I'm using two panels to mimic a simple form, i.e. with no windows icons (close, minimize etc.). One is aligned to the top to pose like the window title bar and the other to client. I want to paint the top panel like a typical title bar. How can I do this?

Answer:

There is an API function named DrawCaption, you can use it to draw the caption bar. Drop a client-aligned TPaintbox on your fake caption panel and do the drawing in the paintboxes OnPaint handler.

procedure TPLabBaseChildform.CaptionPaint(Sender: TObject);
const
  activeFlags: array[Boolean] of DWORD = (0, DC_ACTIVE);
begin
  with Sender as TPaintbox do
    DrawCaption(self.handle, canvas.handle, clientrect, activeFlags[FActive] or
      DC_TEXT or DC_GRADIENT);
end;

To draw other elements as well (beside the icon, which DrawCaption can handle) you use DrawFrameControl instead.

How to convert the content of a TRichEdit into a bitmap

Problem/Question/Abstract:

Does anyone know of a component or a few lines of code, that could turn the contents of a TRichText field (WIN32 RTF) into a bitmap?

Answer:

Add this in the unit your are developing:


uses
  RichText;

{For this demo add a RichEdit and an Image Control set the RichEdit change event to the lower code}

procedure
  OutputRTFToBmp(RichHolder: TRichEdit; ImageHolder: TBitmap; itemwidth, itemheight: real);
var
  Range: TFormatRange;
  TextBoundary: TRect;
begin
  {Setup the Height and Width of our output}
  ImageHolder.width := round(itemwidth * screen.PixelsPerInch);
  ImageHolder.height := round(itemheight * screen.PixelsPerInch);
  {Set the Size of the Rich Edit}
  textboundary := rect(0, 0, round(itemwidth * 1440), round(itemheight * 1440));
  {Set the Range record}
  range.hdc := ImageHolder.Canvas.handle;
  range.hdctarget := ImageHolder.Canvas.handle;
  range.rc := textboundary;
  range.rcpage := textboundary;
  {Start at character zero}
  range.chrg.cpMin := 0;
  {Display all Characters}
  range.chrg.cpMax := -1;
  {Ask RTF to Draw}
  Sendmessage(RichHolder.handle, EM_FORMATRANGE, 1, longint(@range));
  {Cleanup RTF Cache}
  sendmessage(RichHolder.handle, EM_FORMATRANGE, 0, 0);
end;

procedure TForm1.RichEdit1Change(Sender: TObject);
begin
  OutputRTFToBmp(RichEdit1, Image1.picture.bitmap, 2, 2);
  {Display new stuff, this will flicker so you will have to double buffer}
  image1.refresh;
end;


I use it on Metafiles then you can scale it also.

How to do a backward search in a TRichEdit

Problem/Question/Abstract:

How to do a backward search in a TRichEdit

Answer:

Solve 1:

This is how to find text searching backwards:

function FindPreviousInstanceOfSubstring(substr, S: string; startAt: Integer):
  Integer;
var
  i: Integer;
  ch: Char;
begin
  ch := substr[1];
  i := startAt;
  Result := 0; {assume we fail}
  while i >= 1 do
  begin
    if S[i] = ch then
    begin
      if AnsiCompareStr(substr, Copy(S, i, Length(substr))) = 0 then
      begin
        {found an instance}
        Result := i;
        Break;
      end;
    end;
    Dec(i);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  richedit1.selstart := FindPreviousInstanceOfSubstring
    (edit1.text, richedit1.text, richedit1.gettextlen) - 1;
  richedit1.sellength := Length(edit1.text);
end;


Solve 2:

{Function FindTextBackwards

Parameters:
findWhat: text to find
inString: string to find it in
startAt : character index to start at (1-based)
caseSensitive: determines whether search is case-sensitive
words: if true the characters immediately surrounding a found location must not be alphanumeric

Returns: character index (1-based) of first character of a found location, or 0,
if the text was not found.

Description:
Performs a simple sequential search for a string in a larger string, starting at the specified
position and working towards the start of the string.

Error Conditions: none

Created: 27.02.99 by P. Below}

function FindTextBackwards(findWhat, inString: string; startAt: Integer;
  caseSensitive, words: Boolean): Integer;
var
  i, patternlen, findpos: Integer;
  lastchar, firstchar: Char;
begin
  Result := 0; {assume failure}
  patternlen := Length(findWhat);
  {Do a few sanity checks on the parameters}
  if (patternlen = 0) or (startAt < patternlen) or (Length(inString) < patternlen)
    then
    Exit;
  if not caseSensitive then
  begin
    {convert both strings to lower case}
    findWhat := AnsiLowercase(findWhat);
    inString := AnsiLowercase(inString);
  end;
  i := startAt;
  lastchar := findWhat[patternlen];
  firstchar := findWhat[1];
  while (Result = 0) and (i >= patternlen) do
  begin
    if inString[i] = lastchar then
    begin
      findPos := i - patternlen + 1;
      if inString[findPos] = firstchar then
      begin
        {We have a candidate. Compare the substring of length patternlen
                                starting at findPos with findWhat.
                                With AnsiStrLComp we can do that without having to copy the substring to
        a temp string first.}
        if AnsiStrLComp(@findWhat[1], @inString[findPos], patternlen) = 0 then
        begin
          {We have a match!}
          Result := findPos;
          if words then
          begin
            {Check the characters surrounding the hit.
                                                For the hit to constitute a word they must not be alphanumeric.}
            if (findPos > 1) and IsCharAlphanumeric(inString[findPos - 1]) then
            begin
              {Not a match after all}
              Result := 0;
            end
            else
            begin
              if (i < Length(inString)) and IsCharAlphanumeric(inString[i + 1]) then
              begin
                {Not a match after all}
                Result := 0;
              end;
            end;
          end;
        end;
      end;
    end;
    Dec(i);
  end;
end;

Here's how to use it:

procedure TForm1.Button1Click(Sender: TObject);
var
  findPos: Integer;
begin
  findPos := FindTextBackwards(findEdit.Text, richedit1.Text, richedit1.selstart + 1,
    caseCheckbox.checked, wordsCheckbox.checked);
  if findPos > 0 then
  begin
    with richedit1 do
    begin
      selstart := findPos - 1;
      sellength := findEdit.GetTextLen;
      perform(em_scrollcaret, 0, 0);
      setfocus;
    end;
  end
  else
    showmessage('Text not found');
end;

Easy way to compare dates

Problem/Question/Abstract:

Did you know that you can easily compare dates by using the "EncodeDate()"?

Answer:

Here are some examples:

uses
  SysUtils;

{...}

if (Date > EncodeDate(1997, 1, 1)) then
begin
  { display "this program has expired" }
end;

{...}

if (EncodeDate(1997, 1, 1) > EncodeDate(1996, 1, 1)) then
begin
  {...}
end;

How to use MAPI to auto-send new mail

Problem/Question/Abstract:

How can I do ShellExecute(nil, 'open', 'mailto:abc@123.com', nil, nil, sw_shownormal) and auto-send new mail?

Answer:

You'd better try MapiSendMail. This uses the unit MAPI, if MAPI is configured correctly, this works quite fine.

uses
  Mapi;

{ ...}
var
  MapiMessage: TMapiMessage;
  MapiFileDesc: PMapiFileDesc;
  MError: Cardinal;
  FNStr: string;
  R, i: Integer;
begin
  FNStr := AttachedFileName;
  if R <> mrOK then
    exit;
  MapiFileDesc := New(PMapiFileDesc);
  try
    MapiFileDesc.lpszPathName := PChar(FNStr);
    MapiFileDesc.lpszFileName := '';
    with MapiMessage do
    begin
      ulReserved := 0;
      lpszSubject := nil;
      lpszNoteText := '';
      lpszMessageType := nil;
      lpszDateReceived := nil;
      lpszConversationID := nil;
      flFlags := 0;
      lpOriginator := nil;
      nRecipCount := 0;
      lpRecips := nil;
      nFileCount := 1;
      lpFiles := MapiFileDesc;
    end;
    MError := MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or
      MAPI_NEW_SESSION, 0);
    if MError <> 0 then
      MessageDlg(SSendError, mtError, [mbOK], 0);
  finally
    Dispose(MapiFileDesc);
  end;
end;

Scroll my control without flicker effect

Problem/Question/Abstract:

Scroll my control without flicker effect

Answer:

The easiest way to scroll the elements of a control is to force a complete repaint of the control. Unfortunately this produces the flicker effect. You may use

InvalidateRect(MyControl.Handle, nil, FALSE);

(important: last parameter = FALSE) to cause a complete redraw without erasing the background.

The best way to reduce this flickering is to use the ScrollWindow or ScrollWindowEx Windows API function. Look them up in your Win32.HLP file.

Another source of flickering can be from Windows using two messages to paint: WM_PAINT and WM_ERASEBKGND.

You may want to intercept all of the WM_ERASEBKGND messages and do all of your painting, including the background, in response to WM_PAINT messages in the Paint method:


type
  � TMyComponent = class(TWinControl)
    // ..
    � protected
      ��� procedure WMEraseBkgnd(var message: TWMEraseBkgnd);
    ����� message WM_ERASEBKGND;
    // ..
    �
  end;

  // ..

procedure TBMyComponent.WMEraseBkgnd(var message: TWMEraseBkgnd);
begin
  message.Result := 0
end;

How to zoom a polygon

Problem/Question/Abstract:

How can I zoom a polygon? Using SetWorldTransform or how?

Answer:

Here's one possible way:

{ ... }
type
  TPolygon = array of TPoint;

procedure ZoomPolygon(var Polygon: TPolygon; const Center: TPoint; const Scale: Double);
var
  I: Integer;
begin
  for I := 0 to High(Polygon) do
  begin
    Polygon[I].X := Round(Scale * (Polygon[I].X - Center.X) + Center.X);
    Polygon[I].Y := Round(Scale * (Polygon[I].Y - Center.Y) + Center.Y);
  end;
end;

Splitting a string in an dynamic array

Problem/Question/Abstract:

A function that splits a string in parts separated by a substring and returns the parts in a dynamic string array

Answer:

The following functions split a string in parts separated by a substring and return the parts in a dynamic string array:

interface

type
  TStringArray = array of string;

function Split(const str: string;
  const separator: string = ','): TStringArray;
function AnsiSplit(const str: string;
  const separator: string = ','): TStringArray;

implementation

uses sysutils;

function Split(const str: string;
  const separator: string): TStringArray;
// Returns an array with the parts of "str" separated by "separator"
var
  i, n: integer;
  p, q, s: PChar;
begin
  SetLength(Result, Occurs(str, separator) + 1);
  p := PChar(str);
  s := PChar(separator);
  n := Length(separator);
  i := 0;
  repeat
    q := StrPos(p, s);
    if q = nil then
      q := StrScan(p, #0);
    SetString(Result[i], p, q - p);
    p := q + n;
    inc(i);
  until q^ = #0;
end;

function AnsiSplit(const str: string;
  const separator: string): TStringArray;
// Returns an array with the parts of "str" separated by "separator"
// ANSI version
var
  i, n: integer;
  p, q, s: PChar;
begin
  SetLength(Result, AnsiOccurs(str, separator) + 1);
  p := PChar(str);
  s := PChar(separator);
  n := Length(separator);
  i := 0;
  repeat
    q := AnsiStrPos(p, s);
    if q = nil then
      q := AnsiStrScan(p, #0);
    SetString(Result[i], p, q - p);
    p := q + n;
    inc(i);
  until q^ = #0;
end;

Example:

procedure TForm1.Button1Click(Sender: TObject);
var
  a: TStringArray;
  i: integer;
begin
  a := Split('part1,part2,part3');
  for i := 0 to Length(a) - 1 do
  begin // Will show three dialogs
    ShowMessage(a[i]); // 'part1', 'part2', 'part3'
  end;
end;

You can see an example using a StringList instead of a dynamic array in a separate article "Splitting a string in a string list".


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

How to intercept the maximize command

Problem/Question/Abstract:

How to intercept the maximize command

Answer:

If you want to restrict your window's maximum size (or minimum size, for that matter), you may try to intercept WM_SYSCOMMAND and check for the value of wParam.

More elegant is to intercept WM_GETMINMAXINFO, as the following example shows:


type
  TMyForm = class(TForm)
    procedure _WM_GETMINMAXINFO(var mmInfo: TWMGETMINMAXINFO); message
      wm_GetMinMaxInfo;
  end;

  //..

procedure TMyForm._WM_GETMINMAXINFO(var mmInfo: TWMGETMINMAXINFO);
begin
  with mmInfo.minmaxinfo^ do
  begin
    // allow at most half of the screen, and position it in the middle
    ptmaxposition.x := Screen.Width div 4;
    ptmaxposition.y := Screen.Height div 4;

    ptmaxsize.x := Screen.Width div 2;
    ptmaxsize.y := Screen.Height div 2;
  end;
end;

end.