How to set the master volume

Problem/Question/Abstract:

How can I set the master volume? I don't want to use an external file like a DLL.

Answer:

Solve 1:

The "Mixer" parameter of SetMasterVolume has to be either a mixer device ID in the range 0..mixerGetNumDevs-1 or a mixer handle returned by a call to mixerOpen().


interface

uses
  SysUtils, Windows, MMSystem;

procedure SetMasterVolume(Mixer: hMixerObj; Value: Word);

implementation

function GetMasterVolumeControl(Mixer: hMixerObj; var Control: TMixerControl): MMResult;
{Returns True on success}
var
  Line: TMixerLine;
  Controls: TMixerLineControls;
begin
  ZeroMemory(@Line, SizeOf(Line));
  Line.cbStruct := SizeOf(Line);
  Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
  Result := mixerGetLineInfo(Mixer, @Line, MIXER_GETLINEINFOF_COMPONENTTYPE);
  if Result = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@Controls, SizeOf(Controls));
    Controls.cbStruct := SizeOf(Controls);
    Controls.dwLineID := Line.dwLineID;
    Controls.cControls := 1;
    Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
    Controls.cbmxctrl := SizeOf(Control);
    Controls.pamxctrl := @Control;
    Result := mixerGetLineControls(Mixer, @Controls, MIXER_GETLINECONTROLSF_ONEBYTYPE);
  end;
end;

procedure SetMasterVolume(Mixer: hMixerObj; Value: Word);
var
  MasterVolume: TMixerControl;
  Details: TMixerControlDetails;
  UnsignedDetails: TMixerControlDetailsUnsigned;
  Code: MMResult;
begin
  Code := GetMasterVolumeControl(Mixer, MasterVolume);
  if Code = MMSYSERR_NOERROR then
  begin
    with Details do
    begin
      cbStruct := SizeOf(Details);
      dwControlID := MasterVolume.dwControlID;
      cChannels := 1; {set all channels}
      cMultipleItems := 0;
      cbDetails := SizeOf(UnsignedDetails);
      paDetails := @UnsignedDetails;
    end;
    UnsignedDetails.dwValue := Value;
    Code := mixerSetControlDetails(Mixer, @Details, MIXER_SETCONTROLDETAILSF_VALUE);
  end;
  if Code <> MMSYSERR_NOERROR then
    raise Exception.CreateFmt('SetMasterVolume failure, ' + 'multimedia system error #%d', [Code]);
end;


Solve 2:

uses
  MMSystem;

function GetVolumeControl(aMixer: HMixer; componentType, ctrlType: Longint;
  var mxc: TMixerControl): Boolean;
var
  mxl: TMixerLine;
  mxlc: TMixerLineControls;
  rc: Longint;
begin
  Result := FALSE;
  FillChar(mxl, SizeOf(TMixerLine), 0);
  mxl.cbStruct := SizeOf(TMixerLine);
  mxl.dwComponentType := componentType;
  {Obtain a line corresponding to the component type}
  rc := mixerGetLineInfo(aMixer, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);
  if rc = MMSYSERR_NOERROR then
  begin
    mxlc.cbStruct := SizeOf(TMixerLineControls);
    mxlc.dwLineID := mxl.dwLineID;
    mxlc.dwControlType := ctrlType;
    mxlc.cControls := 1;
    mxlc.cbmxctrl := SizeOf(TMixerLine);
    mxlc.pamxctrl := @mxc;
    mxlc.pamxctrl^.cbStruct := SizeOf(TMixerControl);
    mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
    rc := mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
    Result := rc = MMSYSERR_NOERROR;
  end;
end;

function SetVolumeControl(aMixer: HMixer; mxc: TMixerControl; volume:
  LongInt): Boolean;
var
  mxcd: TMixerControlDetails;
  vol: TMixerControlDetails_Unsigned;
  rc: MMRESULT;
begin
  FillChar(mxcd, SizeOf(mxcd), 0);
  mxcd.dwControlID := mxc.dwControlID;
  mxcd.cbStruct := SizeOf(TMixerControlDetails);
  mxcd.cbDetails := SizeOf(TMixerControlDetails_Unsigned);
  mxcd.paDetails := @vol;
  mxcd.cChannels := 1;
  vol.dwValue := volume;
  rc := mixerSetControlDetails(aMixer, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE);
  Result := rc = MMSYSERR_NOERROR;
end;

function InitMixer: HMixer;
var
  Err: MMRESULT;
begin
  Err := mixerOpen(@Result, 0, 0, 0, 0);
  if Err <> MMSYSERR_NOERROR then
    Result := 0;
end;


Usage example:


procedure SetMasterVolumeToZero;
var
  MyMixerHandle: HMixer;
  MyVolCtrl: TMixerControl;
begin
  MyMixerHandle := InitMixer;
  if MyMixerHandle <> 0 then
  try
    FillChar(MyVolCtrl, SizeOf(MyVolCtrl), 0);
    if GetVolumeControl(MyMixerHandle, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS,
      MIXERCONTROL_CONTROLTYPE_VOLUME, MyVolCtrl) then
    begin
      {The last parameter (0) here is the volume level}
      if SetVolumeControl(MyMixer, MyVolCtrl, 0) then
        ShowMessage('Volume should now be set to zero');
    end;
  finally
    mixerClose(MyMixer);
  end;
end;

Calculate a TColor between two other TColors

Problem/Question/Abstract:

I needed a function that calculates a TColor-Value between two others from an Extended. This Extended should be limited from two other Extended Variables.

Answer:

Solve 1:

I needed a function that calculates a TColor-Value between two others from an Extended. This Extended should be limited from two other Extended Variables. All Values  of "Pointvalue" less then "von" will return "Startcolor" and all Pointvalues greater than "Bis" gives EndColor back. Ist written with some Inline- Assemblercode. I think maybee its could be usefull for somebody else.

function GetColorBetween(StartColor, EndColor: TColor; Pointvalue, Von, Bis:
  Extended): TColor;
var
  F: Extended;
  r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
  function CalcColorBytes(fb1, fb2: Byte): Byte;
  begin
    result := fb1;
    if fb1 < fb2 then
      Result := FB1 + Trunc(F * (fb2 - fb1));
    if fb1 > fb2 then
      Result := FB1 - Trunc(F * (fb1 - fb2));
  end;
begin
  if Pointvalue <= Von then
  begin
    result := StartColor;
    exit;
  end;
  if Pointvalue >= Bis then
  begin
    result := EndColor;
    exit;
  end;
  F := (Pointvalue - von) / (Bis - Von);
  asm
     mov EAX, Startcolor
     cmp EAX, EndColor
     je @@exit
     mov r1, AL
     shr EAX,8
     mov g1, AL
     shr Eax,8
     mov b1, AL
     mov Eax, Endcolor
     mov r2, AL
     shr EAX,8
     mov g2, AL
     shr EAX,8
     mov b2, AL
     push ebp
     mov al, r1
     mov dl, r2
     call CalcColorBytes
     pop ecx
     push ebp
     Mov r3, al
     mov dL, g2
     mov al, g1
     call CalcColorBytes
     pop ecx
     push ebp
     mov g3, Al
     mov dL, B2
     mov Al, B1
     call CalcColorBytes
     pop ecx
     mov b3, al
     XOR EAX,EAX
     mov AL, B3
     SHL EAX,8
     mov AL, G3
     SHL EAX,8
     mov AL, R3
     @@Exit:
     mov @result, eax
  end;
end;


Solve 2:

//------------------------------------------------------------------------------
// Function for getting mixed color from two given colors, with a relative
// distance from two colors determined by Position value inside
// MinPosition..MaxPosition range
// Author: Dmitri Papichev (c) 2001
// License type: Freeware
//------------------------------------------------------------------------------

function GetMixedColor(const StartColor,
  EndColor: TColor;
  const MinPosition,
  Position,
  MaxPosition: integer): TColor;
var
  Fraction: double;
  R, G, B,
    R0, G0, B0,
    R1, G1, B1: byte;
begin
  {process Position out of range situation}
  if (MaxPosition < MinPosition) then
  begin
    raise Exception.Create
      ('GetMixedColor: MaxPosition is less then MinPosition');
  end; {if}

  {if Position is outside MinPosition..MaxPosition range, the closest boundary
   is effectively substituted through the adjustment of Fraction}
  Fraction :=
    Min(1, Max(0, (Position - MinPosition) / (MaxPosition - MinPosition)));

  {extract the intensity values}
  R0 := GetRValue(StartColor);
  G0 := GetGValue(StartColor);
  B0 := GetBValue(StartColor);
  R1 := GetRValue(EndColor);
  G1 := GetGValue(EndColor);
  B1 := GetBValue(EndColor);

  {calculate the resulting intensity values}
  R := R0 + Round((R1 - R0) * Fraction);
  G := G0 + Round((G1 - G0) * Fraction);
  B := B0 + Round((B1 - B0) * Fraction);

  {combine intensities in a resulting color}
  Result := RGB(R, G, B);
end; {--GetMixedColor--}

Read the current code page of system

Problem/Question/Abstract:

How to read the code page of system?

Answer:

Sometimes in run-time you must detect the current values of code page.

To detect the code page of Windows operation system you must call the GetACP function from Windows API.

This function will return the value:
874 Thai
932 Japan
936 Chinese (PRC, Singapore)
949 Korean
950 Chinese (Taiwan, Hong Kong)
1200 Unicode (BMP of ISO 10646)
1250 Windows 3.1 Eastern European
1251 Windows 3.1 Cyrillic
1252 Windows 3.1 Latin 1 (US, Western Europe)
1253 Windows 3.1 Greek
1254 Windows 3.1 Turkish
1255 Hebrew
1256 Arabic
1257 Baltic

If you needs to read the code page of "DOS" sessions, you must call the GetOEMCP function from Windows API.
This function will return the value:

437 MS-DOS United States
708 Arabic (ASMO 708)
709 Arabic (ASMO 449+, BCON V4)
710 Arabic (Transparent Arabic)
720 Arabic (Transparent ASMO)
737 Greek (formerly 437G)
775 Baltic
850 MS-DOS Multilingual (Latin I)
852 MS-DOS Slavic (Latin II)
855 IBM Cyrillic (primarily Russian)
857 IBM Turkish
860 MS-DOS Portuguese
861 MS-DOS Icelandic
862 Hebrew
863 MS-DOS Canadian-French
864 Arabic
865 MS-DOS Nordic
866 MS-DOS Russian (former USSR)
869 IBM Modern Greek
874 Thai
932 Japan
936 Chinese (PRC, Singapore)
949 Korean
950 Chinese (Taiwan, Hong Kong)
1361 Korean (Johab)

Also you can check the valids of code page. For example,

if IsValidCodePage(866) then
  ShowMessage('Correct MS-DOS russian code page')

Create a thumbnail from a JPEG image

Problem/Question/Abstract:

Once I was trying to resize a jpeg image and made some Internet search. Believe or not, I couldn't find clear answers to my question, but it's very easy to do.

Answer:

The code below will reduce width and height of a chosen .jpg image.

Go to "File / New / Console Application" and paste this code. Set the SizePct (a const on the code below, but can be a variable on your program) to fit your needs. If you want a new image with 30% of the original width and height set this to 30.

All I do is load the JPEG on a TJPEGImage, create a bitmap and .StretchDraw the JPEG on the bitmap. Then I copy the bitmap to a TJPEGImage using the .Assign method, and, finally, save it.

program Project1;

{$APPTYPE CONSOLE}

uses
  Classes, Windows, SysUtils, Dialogs, JPEG, Graphics;

const
  SizePct: integer = 50; { The new image will have 50% of the original }

var
  OpenDlg: TOpenDialog;
  SaveDlg: TSaveDialog;
  oJPG: TJPEGImage;
  oBmp: TBitmap;

begin
  OpenDlg := TOpenDialog.Create(nil);
  SaveDlg := TSaveDialog.Create(nil);

  if (OpenDlg.Execute) then
  begin
    try
      begin
        oJPG := TJPEGImage.Create;
        oJPG.LoadFromFile(OpenDlg.FileName);
      end
    except
      MessageBox(
        0,
        PChar('Error while trying to open ' +
        OpenDlg.FileName +
        '.'),
        PChar('Error'),
        MB_OK or MB_ICONERROR
        );
      exit;
    end;

    oBmp := TBitmap.Create;
    oBmp.Width := Round(oJPG.Width * SizePct / 100);
    oBmp.Height := Round(oJPG.Height * SizePct / 100);
    oBmp.Canvas.StretchDraw(
      Rect(0, 0, oBmp.Width - 1, oBmp.Height - 1),
      oJPG
      );

    oJPG.Assign(oBmp);
    oJPG.Compress;

    if (SaveDlg.Execute) then
    begin
      oJPG.SaveToFile(SaveDlg.FileName);
    end;

    oBmp.Free;
    oJPG.Free;
  end;

  OpenDlg.Free;
  SaveDlg.Free;

end.

How to run an application in systray mode

Problem/Question/Abstract:

How to run an application in systray mode

Answer:

Solve 1:

Nothing special. It's just a normal application hiding all of its forms and displaying an icon in the systray. The shell takes care of displaying the icon. Just send a message with all info to the shell. Here is an example:

var
  Nid: TNOTIFYICONDATA;

  prodecure ShowTrayIcon();
begin
  nid.cbSize := sizeof(TNOTIFYICONDATA);
  nid.Wnd := Form1.Handle;
  nid.uID := 1;
  nid.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
  nid.uCallbackMessage := WM_MYMESSAGE; {or make it Nil if you don't need it}
  nid.hIcon := LoadIcon(0, IDI_EXCLAMATION); {replace this by your icon}
  lstrcpy(nid.szTip, 'This is my hint');
  Shell_NotifyIcon(NIM_ADD, @nid);
end;

Only have Win32 code for the callback:

function WndProc(hwnd: HWND; msg: integer; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
begin
  case msg of
    WM_MYMESSAGE:
      begin
        case (LOWORD(lParam)) of
          WM_LBUTTONDOWN:
            begin
              MessageBox(hwnd, 'You pressed the left mouse button', 'Caption',
                                                                         MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL);
            end;
          WM_RBUTTONDOWN:
            begin
              PostQuitMessage(0);
              result := 0;
            end
        else
          begin
            result := 0;
          end;
        end;
        result := 1; {true}
      end;
    WM_CLOSE:
      begin
        PostQuitMessage(0);
        result := 0;
        {Exit;}
      end;
    WM_DESTROY:
      begin
        PostQuitMessage(0);
        result := 0;
        {Exit;}
      end;
  end;
  result := DefWindowProc(hwnd, msg, wParam, lParam);
end;


Solve 2:

Try this and don't forget the TImageList holding your icon:

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Shellapi, ImgList, VersionMonitor;

type
  TForm1 = class(TForm)
    ImageList1: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    { Private Declarations }
    Data: PNotifyIconData;
    wm_notifyicon: Cardinal;
    notifyHandle: THandle;
    procedure MyOnClose(var Message: TMessage); message WM_CLOSE;
  public
    { Public Declarations }
    procedure NotifyIconEvnt(var Param: TMessage);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  aIcon: TIcon;
begin
  wm_notifyicon := RegisterWindowMessage('wm_notifyicon');
  notifyHandle := AllocateHWnd(NotifyIconEvnt);
  aIcon := TIcon.Create;
  ImageList1.GetIcon(0, aIcon);
  new(Data);
  Data.cbSize := sizeof(TNotifyIconData);
  Data.Wnd := notifyHandle;
  Data.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
  Data.uCallbackMessage := WM_NOTIFYICON;
  Data.hIcon := aIcon.handle;
  StrCopy(Data.szTip, 'Tooltip hint');
  Shell_NotifyIcon(NIM_ADD, Data);
  SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
  Form1.Visible := False;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Shell_NotifyIcon(NIM_DELETE, Data);
  DeallocateHWnd(notifyHandle);
  dispose(Data);
end;

procedure TForm1.MyOnClose(var Message: TMessage);
begin
  Beep;
  Close;
end;

procedure TForm1.NotifyIconEvnt(var Param: TMessage);
begin
  case Param.LParam of
    WM_LBUTTONDOWN:
      begin
        Form1.Visible := True;
      end;
    WM_RBUTTONDOWN:
      begin
        Form1.Visible := False;
      end;
    WM_CLOSE:
      begin
        DeallocateHWnd(notifyHandle);
        Close;
      end;
  end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  DeallocateHWnd(notifyHandle);
  CanClose := True;
end;

end.

How to get the image size of a JPG, GIF and PNG image file

Problem/Question/Abstract:

How to get the image size of a JPG, GIF and PNG image file

Answer:

Solve 1:

This set of functions shows how to extract the dimensions (width and height) of a JPG, GIF and PNG file. This code was done quite a while back and while it works fine for my purposes, it may be not handle some of the newer stuff like progressive JPEGs and such. Experimentation is highly recommened.

unit ImgSize;

interface

uses Classes;

procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);

implementation

uses SysUtils;

function ReadMWord(f: TFileStream): word;

type
  TMotorolaWord = record
    case byte of
      0: (Value: word);
      1: (Byte1, Byte2: byte);
  end;

var
  MW: TMotorolaWord;
begin
  {It would probably be better to just read these two bytes in normally and
  then do a small ASM routine to swap them. But we aren't talking about
  reading entire files, so I doubt the performance gain would be worth the trouble.}
  f.Read(MW.Byte2, SizeOf(Byte));
  f.Read(MW.Byte1, SizeOf(Byte));
  Result := MW.Value;
end;

procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
const
  ValidSig: array[0..1] of byte = ($FF, $D8);
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
  Sig: array[0..1] of byte;
  f: TFileStream;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  Len: word;
  ReadLen: LongInt;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    ReadLen := f.Read(Sig[0], SizeOf(Sig));
    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then
        ReadLen := 0;
    if ReadLen > 0 then
    begin
      ReadLen := f.Read(Seg, 1);
      while (Seg = $FF) and (ReadLen > 0) do
      begin
        ReadLen := f.Read(Seg, 1);
        if Seg <> $FF then
        begin
          if (Seg = $C0) or (Seg = $C1) then
          begin
            ReadLen := f.Read(Dummy[0], 3); { don't need these bytes }
            wHeight := ReadMWord(f);
            wWidth := ReadMWord(f);
          end
          else
          begin
            if not (Seg in Parameterless) then
            begin
              Len := ReadMWord(f);
              f.Seek(Len - 2, 1);
              f.Read(Seg, 1);
            end
            else
              Seg := $FF; { Fake it to keep looping. }
          end;
        end;
      end;
    end;
  finally
    f.Free;
  end;
end;

procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
type
  TPNGSig = array[0..7] of byte;
const
  ValidSig: TPNGSig = (137, 80, 78, 71, 13, 10, 26, 10);
var
  Sig: TPNGSig;
  f: tFileStream;
  x: integer;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    f.Read(Sig[0], SizeOf(Sig));
    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then
        exit;
    f.Seek(18, 0);
    wWidth := ReadMWord(f);
    f.Seek(22, 0);
    wHeight := ReadMWord(f);
  finally
    f.Free;
  end;
end;

procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
type
  TGIFHeader = record
    Sig: array[0..5] of char;
    ScreenWidth, ScreenHeight: word;
    Flags, Background, Aspect: byte;
  end;
  TGIFImageBlock = record
    Left, Top, Width, Height: word;
    Flags: byte;
  end;
var
  f: file;
  Header: TGifHeader;
  ImageBlock: TGifImageBlock;
  nResult: integer;
  x: integer;
  c: char;
  DimensionsFound: boolean;
begin
  wWidth := 0;
  wHeight := 0;
  if sGifFile = '' then
    exit;

{$I-}

  FileMode := 0; { read-only }
  AssignFile(f, sGifFile);
  reset(f, 1);
  if IOResult <> 0 then
    {Could not open file}
    exit;
  {Read header and ensure valid file}
  BlockRead(f, Header, SizeOf(TGifHeader), nResult);
  if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or (StrLComp('GIF', Header.Sig, 3) <> 0) then
  begin
    {Image file invalid}
    close(f);
    exit;
  end;
  {Skip color map, if there is one}
  if (Header.Flags and $80) > 0 then
  begin
    x := 3 * (1 shl ((Header.Flags and 7) + 1));
    Seek(f, x);
    if IOResult <> 0 then
    begin
      { Color map thrashed }
      close(f);
      exit;
    end;
  end;
  DimensionsFound := False;
  FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
  { Step through blocks }
  BlockRead(f, c, 1, nResult);
  while (not EOF(f)) and (not DimensionsFound) do
  begin
    case c of
      ',': { Found image }
        begin
          BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
          if nResult <> SizeOf(TGIFImageBlock) then
          begin
            { Invalid image block encountered }
            close(f);
            exit;
          end;
          wWidth := ImageBlock.Width;
          wHeight := ImageBlock.Height;
          DimensionsFound := True;
        end;
      ',': { Skip }
        begin
          { NOP }
        end;
      { nothing else, just ignore }
    end;
    BlockRead(f, c, 1, nResult);
  end;
  close(f);

{$I+}

end;

end.


Solve 2:

Getting the size of a *.jpg and *.gif image:


{resourcestring
  SInvalidImage = 'Image is not valid';}

type
  TImageType = (itUnknown, itJPG, itGIF);

function GetImageType(Image: PByte): TImageType;
var
  pImage: PChar;
begin
  pImage := PChar(Image);
  Result := itUnknown;
  if StrLComp(pImage, 'GIF', 3) = 0 then
  begin
    Result := itGIF;
  end
  else if (pImage[0] = #$FF) and (pImage[1] = #$D8) then
  begin
    Result := itJPG;
  end;
end;

procedure GetImageBounds(Image: PByte; Size: Integer; var Width: Cardinal; var Height: Cardinal);
const
  SizeSegments = [#$C0, #$C1, #$C2];
var
  pImage: PChar;
  ImageType: TImageType;
  cSegmentType: Char;
  nSegmentSize: Word;
  nPos: Integer;
  bFound: Boolean;
begin
  ImageType := GetImageType(Image);
  pImage := PChar(Image);
  case ImageType of
    itJPG:
      begin
        nPos := 2;
        bFound := False;
        while not bFound and (nPos < Size) do
        begin
          if pImage[nPos] <> #$FF then
          begin
            EInvalidGraphic.Create(SInvalidImage);
          end;
          Inc(nPos);
          if nPos >= Size then
          begin
            raise EInvalidGraphic.Create(SInvalidImage);
          end;
          cSegmentType := pImage[nPos];
          bFound := cSegmentType in SizeSegments;
          if not bFound then
          begin
            Inc(nPos);
            if not (cSegmentType in [#$01, #$D0..#$D7]) then
            begin
              if nPos >= Size - 1 then
              begin
                raise EInvalidGraphic.Create(SInvalidImage);
              end;
              nSegmentSize := MakeWord(Byte(pImage[nPos + 1]), Byte(pImage[nPos]));
              Inc(nPos, nSegmentSize);
            end;
          end;
        end;
        if not bFound then
        begin
          raise EInvalidGraphic.Create(SInvalidImage);
        end;
        Inc(nPos, 4);
        if nPos >= Size - 1 then
        begin
          raise EInvalidGraphic.Create(SInvalidImage);
        end;
        Height := MakeWord(Byte(pImage[nPos + 1]), Byte(pImage[nPos]));
        Inc(nPos, 2);
        if nPos >= Size - 1 then
        begin
          raise EInvalidGraphic.Create(SInvalidImage);
        end;
        Width := MakeWord(Byte(pImage[nPos + 1]), Byte(pImage[nPos]));
      end;
    itGIF:
      begin
        nPos := 6;
        if nPos >= Size - 1 then
        begin
          raise EInvalidGraphic.Create(SInvalidImage);
        end;
        Width := MakeWord(Byte(pImage[nPos]), Byte(pImage[nPos + 1]));
        nPos := 8;
        if nPos >= Size - 1 then
        begin
          raise EInvalidGraphic.Create(SInvalidImage);
        end;
        Height := MakeWord(Byte(pImage[nPos]), Byte(pImage[nPos + 1]));
      end
  else
    begin
      raise EInvalidGraphic.Create(SInvalidImage);
    end;
  end;
end;


Solve 3:

This is a customization of Solve 1:


function GoodFileRead(fhdl: THandle; buffer: Pointer; readsize: DWord): Boolean;
var
  numread: DWord;
  retval: Boolean;
begin
  retval := ReadFile(fhdl, buffer^, readsize, numread, nil);
  result := retval and (readsize = numread);
end;

function ReadMWord(fh: HFile; var value: Word): Boolean;
type
  TMotorolaWord = record
    case byte of
      0: (Value: word);
      1: (Byte1, Byte2: byte);
  end;
var
  MW: TMotorolaWord;
  numread: DWord;
begin
  { It would probably be better to just read these two bytes in normally and then
  do a small ASM routine to swap them.  But we aren't talking about reading entire files,
  so I doubt the performance gain would be worth the trouble.}
  Result := False;
  if ReadFile(fh, MW.Byte2, SizeOf(Byte), numread, nil) then
    if ReadFile(fh, MW.Byte1, SizeOf(Byte), numread, nil) then
      Result := True;
  Value := MW.Value;
end;

function ImageType(Fname: string): Smallint;
var
  ImgExt: string;
  Itype: Smallint;
begin
  ImgExt := UpperCase(ExtractFileExt(Fname));
  if ImgExt = '.BMP' then
    Itype := 1
  else if (ImgExt = '.JPEG') or (ImgExt = '.JPG') then
    Itype := 2
  else
    Itype := 0;
  Result := Itype;
end;

function FetchBitmapHeader(PictFileName: string; var wd, ht: Word): Boolean;
{similar routine is in "BitmapRegion" routine}
label
  ErrExit;
const
  ValidSig: array[0..1] of byte = ($FF, $D8);
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
  BmpSig = $4D42;
var
  {Err : Boolean;}
  fh: HFile;
  {tof : TOFSTRUCT;}
  bf: TBITMAPFILEHEADER;
  bh: TBITMAPINFOHEADER;
  {JpgImg  : TJPEGImage;}
  Itype: Smallint;
  Sig: array[0..1] of byte;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  skipLen: word;
  OkBmp, Readgood: Boolean;
begin
  {Open the file and get a handle to it's BITMAPINFO}
  OkBmp := False;
  Itype := ImageType(PictFileName);
  fh := CreateFile(PChar(PictFileName), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if (fh = INVALID_HANDLE_VALUE) then
    goto ErrExit;
  if Itype = 1 then
  begin
    {read the BITMAPFILEHEADER}
    if not GoodFileRead(fh, @bf, sizeof(bf)) then
      goto ErrExit;
    if (bf.bfType <> BmpSig) then {'BM'}
      goto ErrExit;
    if not GoodFileRead(fh, @bh, sizeof(bh)) then
      goto ErrExit;
    {for now, don't even deal with CORE headers}
    if (bh.biSize = sizeof(TBITMAPCOREHEADER)) then
      goto ErrExit;
    wd := bh.biWidth;
    ht := bh.biheight;
    OkBmp := True;
  end
  else if (Itype = 2) then
  begin
    FillChar(Sig, SizeOf(Sig), #0);
    if not GoodFileRead(fh, @Sig[0], sizeof(Sig)) then
      goto ErrExit;
    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then
        goto ErrExit;
    Readgood := GoodFileRead(fh, @Seg, sizeof(Seg));
    while (Seg = $FF) and Readgood do
    begin
      Readgood := GoodFileRead(fh, @Seg, sizeof(Seg));
      if Seg <> $FF then
      begin
        if (Seg = $C0) or (Seg = $C1) or (Seg = $C2) then
        begin
          Readgood := GoodFileRead(fh, @Dummy[0], 3); {don't need these bytes}
          if ReadMWord(fh, ht) and ReadMWord(fh, wd) then
            OkBmp := True;
        end
        else
        begin
          if not (Seg in Parameterless) then
          begin
            ReadMWord(fh, skipLen);
            SetFilePointer(fh, skipLen - 2, nil, FILE_CURRENT);
            GoodFileRead(fh, @Seg, sizeof(Seg));
          end
          else
            Seg := $FF; {Fake it to keep looping}
        end;
      end;
    end;
  end;
  ErrExit: CloseHandle(fh);
  Result := OkBmp;
end;

Antialiased line drawer

Problem/Question/Abstract:

How do I draw smooth lines in my apps like photoshop?

Answer:

procedure AALine(x1, y1, x2, y2: single; color: tcolor; canvas: tcanvas);
  function CrossFadeColor(FromColor, ToColor: TColor; Rate: Single): TColor;
  var
    r, g, b: byte;
  begin
    r := Round(GetRValue(FromColor) * Rate + GetRValue(ToColor) * (1 - Rate));
    g := Round(GetGValue(FromColor) * Rate + GetGValue(ToColor) * (1 - Rate));
    b := Round(GetBValue(FromColor) * Rate + GetBValue(ToColor) * (1 - Rate));
    Result := RGB(r, g, b);
  end;
  procedure hpixel(x: single; y: integer);
  var
    FadeRate: single;
  begin
    FadeRate := x - trunc(x);
    with canvas do
    begin
      pixels[trunc(x), y] := CrossFadeColor(Color, Pixels[Trunc(x), y], 1 - FadeRate);
      pixels[trunc(x) + 1, y] := CrossFadeColor(Color, Pixels[Trunc(x) + 1, y],
        FadeRate);
    end;
  end;

  procedure vpixel(x: integer; y: single);
  var
    FadeRate: single;
  begin
    FadeRate := y - trunc(y);
    with canvas do
    begin
      pixels[x, trunc(y)] := CrossFadeColor(Color, Pixels[x, Trunc(y)], 1 - FadeRate);
      pixels[x, trunc(y) + 1] := CrossFadeColor(Color, Pixels[x, Trunc(y) + 1],
        FadeRate);
    end;
  end;

var
  i: integer;
  ly, lx, currentx, currenty, deltax, deltay, l, skipl: single;
begin
  if (x1 <> x2) or (y1 <> y2) then
  begin
    currentx := x1;
    currenty := y1;
    lx := abs(x2 - x1);
    ly := abs(y2 - y1);

    if lx > ly then
    begin
      l := trunc(lx);
      deltay := (y2 - y1) / l;
      if x1 > x2 then
      begin
        deltax := -1;
        skipl := (currentx - trunc(currentx));
      end
      else
      begin
        deltax := 1;
        skipl := 1 - (currentx - trunc(currentx));
      end;
    end
    else
    begin
      l := trunc(ly);
      deltax := (x2 - x1) / l;
      if y1 > y2 then
      begin
        deltay := -1;
        skipl := (currenty - trunc(currenty));
      end
      else
      begin
        deltay := 1;
        skipl := 1 - (currenty - trunc(currenty));
      end;
    end;

    currentx := currentx + deltax * skipl;
    currenty := currenty + deltay * skipl; {}

    for i := 1 to trunc(l) do
    begin
      if lx > ly then
        vpixel(trunc(currentx), currenty)
      else
        hpixel(currentx, trunc(currenty));
      currentx := currentx + deltax;
      currenty := currenty + deltay;
    end;
  end;
end;

Make TextOut with 3d-Effect or hollow Text

Problem/Question/Abstract:

How to make TextOut with 3d-Effect or hollow Text

Answer:

Make a new Application and take this Proc bellow for the OnPaint-Event of the Form. The TextOutput will look like written with a kaligraf.If You replace the for loop in the proc with a single call of textout you can use this code to write "hollow" text. Try it with different Pen-Styles too!

procedure TForm1.FormPaint(Sender: TObject);
var
  HFnt: HFONT;
  Fontname, Txt: PChar;
  sze: Size;
  c: Integer;
  byt: Byte;
begin
  Fontname := 'Arial';
  txt := 'Mediakueche';
  HFnt := CreateFont(90, 60, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
    PROOF_QUALITY, DEFAULT_PITCH + FF_DONTCARE, Fontname);
  SelectObject(Canvas.Handle, hfnt);
  SetBkMode(Canvas.Handle, TRANSPARENT);
  GetTextExtentPoint32(Canvas.Handle, txt, length(txt), sze);
  BeginPath(Canvas.Handle);
  c := 1;
  for c := 0 to 4 do
  begin
    TextOut(Canvas.Handle, 5 + c, 10 + c, Txt, length(Txt));
  end;
  EndPath(Canvas.Handle);
  //  Canvas.pen.Style := psDot;
  StrokePath(Canvas.Handle);
  SetBkMode(Canvas.Handle, OPAQUE);

  DeleteObject(SelectObject(Canvas.Handle, GetStockObject(WHITE_BRUSH)));
  SelectObject(Canvas.Handle, GetStockObject(SYSTEM_FONT));
  DeleteObject(HFnt);

end;

Very simple connection to an Access 2000 database using ADO

Problem/Question/Abstract:

How can I connect my Application to an Access 2000 Database

Answer:

You have an access 2000 Database with a few table and are not very familiar with ADO. You want to, at least, connect you database to your application (For example one of your friend don't have an access viewer and you want him to be able to read you Tip and Trick DataBase).

Here how it work.

First put a TADOConnection Component on your form. Open the object inspector and search for the connection string property. Click the 3 dot icon (...). You should see a windows with the following title bar:
Form1.ADOConnection1 Connection String

As it's our first connection ever we gonna use a connection string as
connection Source. Click the second radio button. Don't type anything in the textbox, just click the build button to automate the process.

Another windows appear named Data Link Properties. There 4 sections called Provider, Connection, Advanced ans All. Go in provider.
As I don't want to go in detail and let you make a quick connection I recommend you chose the latest Microsoft Jet OLE Provider. On my version it's 4.0, if you don't have updated yet your sustem it will be 3.51. Click Next.

You are now in the connection section. Click the 3 dot (...) to access your database with the open dialog. Ok following you are not a DataBase expert and don't share it with other users you don't need any login name / password, so delete the Admin default username.  
We don't need to edit the Advanced and All section. Leaves that blank and click ok, click ok another time.

Back to the form.

Open the object inspector. First set the LoginPrompt to false. Got to the connected property, make it true. You are connected!

Wanna be sure? Yes, all was done non visual. We will put some visual components on the form but first we need to complete the non visual part.

Add a TADODataSet to the form. Go to the Connection propery, click down and choose ADOConnection1. In CommandType click cmdTableDirect, we don't need any fancy thing, let's get straight to the point. In the command text property click down and select the main table of you app (I assume for this article that you have only one table). In the active property click true.

The rest go a lot like BDE application. Go to the DataAccess category and put a TDataSource component on the form. Put it's DataSet property to ADODataSet1.

We're ready for a visual component. Now put a TDBGrid on the form.
In the DataSource property choose DataSource1.

That's it your connected!

How to change the TCheckBox state without assigning an OnClick event handler

Problem/Question/Abstract:

I was wondering if there was any way to change the state of the TCheckBox control without setting off the OnClick Event Handler. If certain other properties are incorrect, I want void the state the event was set to by the Click, without setting of the event handler again.

Answer:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Button1.Tag = 0 then
  begin
    SendMessage(CheckBox1.handle, BM_SETCHECK, BST_CHECKED, 0);
    Button1.Tag := 1;
  end
  else
  begin
    SendMessage(CheckBox1.handle, BM_SETCHECK, BST_UNCHECKED, 0);
    Button1.Tag := 0;
  end;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  Showmessage('clicked');
end;

Copying Files in Delphi

Problem/Question/Abstract:

How do I copy a file in Delphi?

Answer:

Reminiscing on Days Gone By...

Back in the old DOS days, we took for granted copying a file from one place to another with the copy command. But with Windows, everything changed. We now use File Manager or Explorer to copy files from one place to another, which is a huge improvement over typing in the fully qualified path for both source and destination files.

But at the programming level, performing the copying of one file to another is not as apparent as one would think. In fact, there are no native Delphi calls for copying a file whatsoever. So what do you do if you want to copy a file? You have to write the routine yourself.

Interestingly enough, there is a pretty good example of copying a file that is in the FMXUTILS.PAS file in the Delphi\Demos\Doc\Filmanex directory that will perform a file copy using native Delphi file-related commands. While this method works just fine, I decided to go another route; that is, to use a file stream to copy a file from one place to another. Streams are interesting animals. They're used internally in Delphi to read and write components, forms and data, and they're pretty handy. Unfortunately, they aren't well-documented so they can be a bit tricky to use. I went through a lot of trial and error to get them to work, and referenced several sources outside of the online help (which is just about the only place you'll find anything on streams in Delphi) before I got a handle on streams. But once I figured them out, they became what I use for reading and writing files almost exclusively.

There's Almost Always More Than One Way of Doing Things...

Once you've programmed for a while, you realize that it's possible to solve a particular problem in a variety of ways; which way is valid is dependent upon your knowledge and experience (one way may be more optimized than another) or, at times, even the situation will dictate that one methodology is better suited for a task than another.

For instance, with file copying, there are times you just want to copy a file in the background using a quick and dirty method, and you don't care if the user knows what's going on at all. But there are other times, such as when file utilities are part of an interface, when you want the user to be aware of the copying progress.

What I'm going to show you here are two ways to perform file copying: one quick and dirty; the other, a more snazzy, graphical way of copying a file, though it uses a few more resources and is a bit slower.

Quick and Dirty Copying

Traditionally, copying a file involves using a loop to move a series of blocks from one file into a temporary buffer, then copying the contents of the buffer into another file. Let's look at the CopyFile function found in the FMXUTILS.PAS:

{=============================================================================
CopyFile procedure found in the FMXUTILS.PAS file in Delphi\Demos\Doc\Filmanex
This is an example of copying a file using a buffer.
=============================================================================}

procedure CopyFile(const FileName, DestName: TFileName);
var
  CopyBuffer: Pointer; { buffer for copying }
  TimeStamp, BytesCopied: Longint;
  Source, Dest: Integer; { handles }
  Destination: TFileName; { holder for expanded destination name }
const
  ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
  Destination := ExpandFileName(DestName); { expand the destination path }
  if HasAttr(Destination, faDirectory) then { if destination is a directory... }
    Destination := Destination + '\' + ExtractFileName(FileName);
      { ...clone file name }
  TimeStamp := FileAge(FileName); { get source's time stamp }
  GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  try
    Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
    if Source < 0 then
      raise EFOpenError.Create(FmtLoadStr(SFOpenError, [FileName]));
    try
      Dest := FileCreate(Destination); { create output file; overwrite existing }
      if Dest < 0 then
        raise EFCreateError.Create(FmtLoadStr(SFCreateError, [Destination]));
      try
        repeat
          BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk }
          if BytesCopied > 0 then { if we read anything... }
            FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
        until BytesCopied < ChunkSize; { until we run out of chunks }
      finally
        FileClose(Dest); { close the destination file }
      end;
    finally
      FileClose(Source); { close the source file }
    end;
  finally
    FreeMem(CopyBuffer, ChunkSize); { free the buffer }
  end;
end;

But Delphi implements a method of TStream called CopyFrom that allows you to copy the entire contents of one stream into another in one fell swoop. Here's an implementation of copying a file using the CopyFrom method:

{=============================================================
Quick and dirty copying using the CopyFrom method of TStream.
=============================================================}

procedure FileCopy(const FSrc, FDst: string);
var
  sStream,
    dStream: TFileStream;
begin
  sStream := TFileStream.Create(FSrc, fmOpenRead);
  try
    dStream := TFileStream.Create(FDst, fmCreate);
    try
      {Forget about block reads and writes, just copy
       the whole darn thing.}
      dStream.CopyFrom(sStream, 0);
    finally
      dStream.Free;
    end;
  finally
    sStream.Free;
  end;
end;

The declaration of the CopyFrom method is as follows:

function CopyFrom(Source: TStream; Count: LongInt): LongInt;

Source is the TStream you're going to copy from, and Count is the number of bytes to copy from the stream. If Count is zero (0), the entire contents of the source stream is copied over. This makes for a quick one-liner copying.

Notice that in both the examples above, all the functionality is enclosed in nested try..finally blocks. This is extremely important because just in case something goes wrong, all resources and pointers that are created are freed. You don't want to have stray pointers or unreleased memory in your system, so providing at least this level of exception handling is key to ensuring that you don't.

A Sexier File Copy

If you write robust user interfaces, practically everything that you do involves interacting with the user by providing visual cues to let the user know what's going on. File copying is one of those types of operations that when performed within the context of a user interface must provide some status as to the progress of the copy operation. Therefore, a quick and dirty copy like the one I just described above won't do. What we need then is something with a bit more pizazz.

In order to get status, we need to copy the file in chunks. That way, as we copy each chunk from one file to another, we can let the user know how far we've proceeded. What this implies is that we need two pieces. The first is the unit that performs the copying; the other a status window used for notification. For me, the best way to get both pieces to work in concert was to build a custom component which encapsulates the file copy operation and uses another unit to perform the notification.

The notification unit is just a simple form with a TGauge and a TButton placed on it. The unit code is as follows:

unit copyprg;

interface

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

type
  TFileProg = class(TForm)
    Gauge1: TGauge;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    fCancel: Boolean;
  public
    property CancelIt: Boolean read fCancel;
  end;

var
  FileProg: TFileProg;

implementation

{$R *.DFM}

procedure TFileProg.Button1Click(Sender: TObject);
begin
  fCancel := True;
end;

procedure TFileProg.FormCreate(Sender: TObject);
begin
  fCancel := False;
end;

end.

Nothing odd here. I simply added a custom property to the form called CancelIt, which is a simple Boolean flag used to cancel the copying operation midstream should the user desire to do so. The real work happens in the custom component itself. Let's look at its code, then discuss it:

unit FileCopy;

interface

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

type
  TFileCopy = class(TComponent)
  private
    FSource,
      FDest: string;
    procedure DoCopyFile(const SrcFile, DstFile: string);
  public
    procedure CopyFile; virtual;
  published
    property FileSource: string read FSource write FSource;
    property FileDestination: string read FDest write FDest;
  end;

procedure Register;

implementation

uses copyprg;

procedure TFileCopy.CopyFile;
begin
  DoCopyFile(FileSource, FileDestination);
end;

procedure TFileCopy.DoCopyFile(const SrcFile, DstFile: string);
const
  bufSize = 16384; {Use a 16K buffer. You can use whatever size suits you, though.}
var
  sStream,
    dStream: TFileStream;
  pBuf: Pointer;
  cnt: Integer;
  prgFrm: TFileProg;
  totCnt,
    X,
    strmSize: LongInt;
begin
  totCnt := 0;
  {Open up the Source File to read it}
  sStream := TFileStream.Create(SrcFile, fmOpenRead or fmShareDenyWrite);

  {Create the copying progress form and set property values}
  prgFrm := TFileProg.Create(Application);
  with prgFrm.Gauge1 do
  begin
    MinValue := 0;
    MaxValue := 100;
    Progress := 0;
  end;
  prgFrm.Show;

  {Get the size of the entire stream to use for the progress gauge. Note
   we have to call FileSeek first because it will place the pointer
   at the end of the file when we get the file first return value.}
  strmSize := sStream.size;

  try
    { Create the destination file. If it already exists,
      overwrite it. }
    dStream := TFileStream.Create(DstFile, fmCreate or fmShareExclusive);
    try
      GetMem(pBuf, bufSize);
      try
        {Read and write first bufSize bytes from source into the buffer
         If the file size is smaller than the default buffer size, then
         all the user will see is a quick flash of the progress form.}
        cnt := sStream.Read(pBuf^, bufSize);
        cnt := dStream.Write(pBuf^, cnt);

        totCnt := totCnt + cnt;
        {Loop the process of reading and writing}
        while (cnt > 0) do
        begin
          {Let things in the background proceed while loop is processing}
          Application.ProcessMessages;

          {Read bufSize bytes from source into the buffer}
          cnt := sStream.Read(pBuf^, bufSize);

          {Now write those bytes into destination}
          cnt := dStream.Write(pBuf^, cnt);

          {Increment totCnt for progress and do arithmetic to update the
           gauge}
          totcnt := totcnt + cnt;
          if not prgFrm.CancelIt then
            with prgFrm.Gauge1 do
            begin
              Progress := Round((totCnt / strmSize) * 100);
              Update;
            end
          else
            Break; {If user presses cancel button, then break out of loop}
          {which will make program go to finally blocks}
        end;

      finally
        FreeMem(pBuf, bufSize);
      end;
    finally
      dStream.Free;
      if prgFrm.CancelIt then {If copying was cancelled, delete the destination file}
        DeleteFile(DstFile); {after stream has been freed, which will close the file.}
    end;
  finally
    sStream.Free;
    prgFrm.Close;
  end;
end;

procedure Register;
begin
  {You can change the palette entry to something of your choice}
  RegisterComponents('BD', [TFileCopy]);
end;

end.

Like the CopyFile routine in FMXUTILS.PAS, the concept behind copying for this component is the same: Grab a chunk of the source file, then dump it into the destination file. Repeat this process until all possible data has been copied over. Notice that I used a TFileStream once again. But this time, I didn't copy the entire file over in one fell swoop. That would've defeated the whole purpose of providing user status.

I've commented the code extensively, so I won't go into real detail here. I'll leave it up to you to study the code to learn about what's going on in it.

Notice the method declaration for CopyFile is declared as a virtual method. I've done this on purpose so that this class can be used a template class for specialized copy operations. The CopyFile method is actually rather trivial at this level -- all it does is call the DoCopyFile method and pass the FileSource and FileDestination property values.

However, it is the only public interface for actually performing the copying operation. This is an important point for all you component designers out there. Providing limited method visibility ensures that the core features of your components remain intact. Remember, you want other users of your component to see only what is absolutely necessary.

How is this useful? It allows you to have a bit of control over how the hierarchy develops. By hiding the basic functionality from descendant classes, you can ensure that the basic functionality of your class is retained throughout the inheritance tree. Granted, users can completely override the behavior of the CopyFile method, but that doesn't mean that the original capability will be lost. It will still be there, just not implemented.

Obviously, the meat of the work is performed by the DoCopyFile method. Study the code to see what happens from point to point. Note that I used a Pointer for the buffer. You can use just about any type as a buffer, but a pointer makes sense because its a simple 4-byte value. If you are copying a text file and want to treat the pointer like a string, you can cast it as a PChar, so long as you append a #0 byte to the end of the buffer. Neat stuff, huh?

A Little Note About TFileStream

TFileStream is not a direct assignment of TStream. In fact, it's a descendant of THandleStream which, when created, fills a property value called Handle which is the handle to an external file. TFileStream inherits the Handle property. The significance of this is really neat: File operations that take a handle as input can be applied to a TFileStream. That has interesting implications in that you can do file operations on a TFileStream object before you write it to another place. Try experimenting with this.

Okay, we've come a long way. And no, I haven't delved into the depths of Stream classes. That's probably best left to another article or series of articles. In any case, play around with the TCopyFile class. It could prove to be a useful addition to your applications.

How can I close a MessageBox()

Problem/Question/Abstract:

How can I close a MessageBox()

Answer:

You can use a thread to achieve that:

unit MsgThread;

interface

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

type
  TMboxThread = class(TThread)
  private
    { private declarations }
  protected
    procedure Execute; override;
  public
    constructor Create;
  end;

type
  TFrmMsgThread = class(TForm)
    BtnClose: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Timer1: TTimer;
    procedure BtnCloseClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FFirst: boolean;
    FMboxThread: TMBoxThread;
    FWinHandle: HWnd;
  public
    { public declarations }
  end;

var
  FrmMsgThread: TFrmMsgThread;

implementation

{$R *.DFM}

{ TMboxThread }

constructor TMboxThread.Create;
begin
  FreeOnTerminate := True;
  inherited Create(False);
end;

procedure TMboxThread.Execute;
begin
  { Place thread code here }
  MessageBox(Application.Handle, 'Text', 'Caption',
    MB_APPLMODAL + MB_SETFOREGROUND);
end;

{ TForm1 }

procedure TFrmMsgThread.BtnCloseClick(Sender: TObject);
begin
  FMBoxThread := TMBoxThread.Create;
  FFirst := true;
  Timer1.Enabled := true;
end;

procedure TFrmMsgThread.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := false;
  if FFirst then
  begin
    FWinHandle := GetForegroundWindow;
    FFirst := false;
    Timer1.Enabled := true;
  end
  else
    SendMessage(FWinHandle, WM_CLOSE, 0, 0);
end;

end.

How to display text from a TRichEdit on the canvas of a TGraphicControl

Problem/Question/Abstract:

How to display text from a TRichEdit on the canvas of a TGraphicControl

Answer:

If you just want to view the text you can make a component derived from TGraphicControl. The following code shows how to put text from a TRichEdit control on the canvas of the TGraphicControl.

{rtf is a property of the TRICHLABEL of the type TRichEdit }

procedure TRICHLABEL.Paint;
var
  myFormatRange: TFormatRange;
  myCharRange: TCharRange;
  myRect: TRect;
  OldMap: Integer;
  LastChar: Integer;
  rc: TRect;
  hDC, hDCTarget: THandle;
begin
  if not Assigned(rtf) then
    exit;
  FillChar(myFormatRange, sizeof(TFormatRange), 0);
  myCharRange.cpMin := 0;
  myCharRange.cpMax := -1;
  canvas.brush.color := BackColor;
  if FTransparent then
    Canvas.brush.style := bsClear
  else
  begin
    Canvas.brush.style := bsSolid;
    Canvas.FillRect(ClientRect);
  end;
  with myFormatRange do
  begin
    hDC := canvas.handle;
    hDCTarget := canvas.handle;
    rc := Rect(0, ptOrigin.y * 15, Width * 15, ptOrigin.y * 15 + Height * 15);
    chrg.cpMin := 0;
    chrg.cpMax := -1;
  end;
  LastChar := SendMessage(rtf.handle, EM_FORMATRANGE, 1, LPARAM(@myFormatRange));
  myRect := Rect(0, 0, width * 15, height * 15);
  SendMessage(rtf.handle, EM_DISPLAYBAND, 0, LPARAM(@myRect));
  LastChar := SendMessage(rtf.handle, EM_FORMATRANGE, 0, LPARAM(nil));
end;

Creating weird shaped forms

Problem/Question/Abstract:

Is it possible to create forms with shapes other than the standard rectangular shape in Windows?

Answer:

Sometimes it's just not enough to write applications that have the same boring rectangular forms over and over again. Sometimes you need a change. How about an elliptical form? Or maybe even a triangular form? Sound intriguing? It's not that hard to  do.

New in Win32 is something called a region. The Win32 API Programmer's Reference defines a region as follows:

...a rectangle, polygon or ellipse (or a combination of two or more of these shapes) that can be filled, painted, inverted, framed and used to perform hit testing (testing for the cursor location).

From the definition, the most notable thing about a region is that it can be manipulated in a variety of ways. For our purposes we want to define a region to create a specific shape.

I should point out that a region can be defined for just about any TWinControl descendant (not just forms), meaning you can apply a region to a TPanel or even a TEdit (though I strongly recommend against it). But to alter the shape of a TWinControl descendant, all you need to provide is a handle and employ some handy-dandy shape change functions.

To get a control to change its shape, follow this two-step process:

Define the boundaries of the region that represent a particular shape.
Apply the boundaries you've defined to a window.

This is pretty simple. However, it's very important to refer to the help file, and to have the source at hand. I wouldn't be able to accomplish many of my projects, let alone write many of the articles I write here, without those two resources at my disposal. Especially with the Windows API calls, having access to the Window.PAS file is essential so I know what to pass into the functions. Remember, the WinAPI calls are really wrapper calls into the appropriate Windows DLLs, and of course, the help file is essential to getting background information on the topic you're interested in.

With respect to this article, look up the SetWindowRgn topic in Win32 Developer's Help, and have it handy while you're putting together your program. Pay particular attention to the Group hyperlink because it will give you a run-down of all the procedures related to the region topic. Let's move on!

Defining a Region's Boundary

The first step to creating a form of a different shape is to define the shape itself. For our discussion, we'll use three WinAPI calls:

CreateEllipticRgn
This function will create an elliptically-shaped region.
CreateRoundRectRgn
This will create a rectangular region with rounded corners.
CreatePolygonRgn
This will create just about any multi-sided shape, as long as the lines form a closed solid.

These functions return a HRGN type, which will then be used by a function called SetWindowRgn whose sole purpose in life it is to set the parameters defined by a particular region variable. I've encapsulated these functions in methods that are part of a demonstration form. The functions are coded as follows:

{===========================================================================
  Notice that all the functions are used in an assignment
  operation to a variable called rgn. This is a
  private var that I declared for the form. The private var is
  accessible to all functions; I did this so that I could change the shape of
  the form or a control on the form, and use the same region.
===========================================================================}

procedure TForm1.DrawEllipticRegion(wnd: HWND; rect: TRect);
begin
  rgn := CreateEllipticRgn(rect.left, rect.top, rect.right, rect.bottom);
  SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.DrawRndRectRegion(wnd: HWND; rect: TRect);
begin
  rgn := CreateRoundRectRgn(rect.left, rect.top, rect.right, rect.bottom, 30, 30);
  SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.DrawPolygonRegion(wnd: HWND; rect: TRect; NumPoints: Integer;
  DoStarShape: Boolean);
const
  RadConvert = PI / 180;
  Degrees = 360;
  MaxLines = 100;
var
  x, y,
    xCenter,
    yCenter,
    radius,
    pts,
    I: Integer;
  angle,
    rotation: Extended;
  arPts: array[0..MaxLines] of TPoint;
begin

  xCenter := (rect.Right - rect.Left) div 2;
  yCenter := (rect.Bottom - rect.Top) div 2;
  if DoStarShape then
  begin
    rotation := Degrees / (2 * NumPoints);
    pts := 2 * NumPoints;
  end
  else
  begin
    rotation := Degrees / NumPoints; //get number of degrees to turn per point
    pts := NumPoints
  end;
  radius := yCenter;

  {This loop defines the Cartesian points of the shape. Notice
   I've added 90 degrees to the rotation angle. This is so that shapes will
   stand up; otherwise they'll lie on their sides. I had to
   brush up on my trigonometry to accomplish this (forgot all those sin and cos
   thingies. Many thanks to Terry Smithwick and David Ullrich for their
   assistance on CompuServe!}
  for I := 0 to pts - 1 do
  begin
    if DoStarShape then
      if (I mod 2) = 0 then //which means that
        radius := Round(radius / 2)
      else
        radius := yCenter;

    angle := ((I * rotation) + 90) * RadConvert;
    x := xCenter + Round(cos(angle) * radius);
    y := yCenter - Round(sin(angle) * radius);
    arPts[I].X := x;
    arPts[I].Y := y;
  end;

  rgn := CreatePolygonRgn(arPts, pts, WINDING);
  SetWindowRgn(wnd, rgn, TRUE);
end;

The first two functions are pretty simple, just two-liners. All that's needed to create the appropriate shapes is a handle and a TRect structure. For forms, that structure would be taken from the ClientRect property; for other controls, use the BoundsRect property.

The DrawPolygonRegion method, however, is much more complex. This is due in part to the fact that CreatePolygonRgn requires the vertices of the corners of the polygon to be passed as an array of TPoints, and partly because I wanted to draw equilateral polygons based off points rotated around a common center point. For that I had to use some trigonometry.

I wanted to not only draw polygon regions, but stars as well. Using rotational trig allowed me to do it. The way the function works if the DrawStarShape parameter is set to True is that for every even value of I in the loop, the radius of the circle is set to half its length, and to maintain the number of points of the polygon I want to draw, I double the number of points to accomodate the contraction of the radius.

At the very end of each function is a call to SetWindowRgn. This function takes as parameters a window handle, a rgn var, and a Boolean value that specifies whether the window should be re-drawn. In all cases, if you want to see the shape you've made, this must be always be set to True.

Below is the listing for the entire source code of my test form. On the form I've dropped four TButtons (one for each of the shapes: ellipse, round rectangle, polygon and star); a TPanel to demonstrate the ability to set regions for TWinControl descendants other than TForm; and a SpinEdit used in conjunction with the Polygon and Star region buttons to define the number of points that'll be defining the shape. Here's the code:

unit regmain;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    SpinEdit1: TSpinEdit;
    Button4: TButton;
    Panel1: TPanel;
    Edit1: TEdit;
    procedure DrawRndRectRegion(wnd: HWND; rect: TRect);
    procedure DrawEllipticRegion(wnd: HWND; rect: TRect);
    procedure DrawPolygonRegion(wnd: HWND; rect: TRect; NumPoints: Integer;
      DoStarShape: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
    rgn: HRGN;
    rect: TRect;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DrawRndRectRegion(wnd: HWND; rect: TRect);
begin
  rgn := CreateRoundRectRgn(rect.left, rect.top, rect.right, rect.bottom, 30, 30);
  SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.DrawEllipticRegion(wnd: HWND; rect: TRect);
begin
  rgn := CreateEllipticRgn(rect.left, rect.top, rect.right, rect.bottom);
  SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.DrawPolygonRegion(wnd: HWND; rect: TRect; NumPoints: Integer;
  DoStarShape: Boolean);
const
  RadConvert = PI / 180;
  Degrees = 360;
  MaxLines = 100;
var
  x, y,
    xCenter,
    yCenter,
    radius,
    pts,
    I: Integer;
  angle,
    rotation: Extended;
  arPts: array[0..MaxLines] of TPoint;
begin

  xCenter := (rect.Right - rect.Left) div 2;
  yCenter := (rect.Bottom - rect.Top) div 2;
  if DoStarShape then
  begin
    rotation := Degrees / (2 * NumPoints);
    pts := 2 * NumPoints;
  end
  else
  begin
    rotation := Degrees / NumPoints; //get number of degrees to turn per point
    pts := NumPoints
  end;
  radius := yCenter;

  {This loop defines the Cartesian points of the shape. Again,
   I've added 90 degrees to the rotation angle so the shapes will
   stand up rather than lie on their sides. Thanks again to Terry Smithwick and
   David Ullrich for their trig help on CompuServe.}
  for I := 0 to pts - 1 do
  begin
    if DoStarShape then
      if (I mod 2) = 0 then //which means that
        radius := Round(radius / 2)
      else
        radius := yCenter;

    angle := ((I * rotation) + 90) * RadConvert;
    x := xCenter + Round(cos(angle) * radius);
    y := yCenter - Round(sin(angle) * radius);
    arPts[I].X := x;
    arPts[I].Y := y;
  end;

  rgn := CreatePolygonRgn(arPts, pts, WINDING);
  SetWindowRgn(wnd, rgn, TRUE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawEllipticRegion(Form1.Handle, Form1.ClientRect);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DrawPolygonRegion(Panel1.Handle, Panel1.BoundsRect, SpinEdit1.Value, False);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  DrawRndRectRegion(Form1.Handle, Form1.ClientRect);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  DrawPolygonRegion(Panel1.Handle, Panel1.BoundsRect, SpinEdit1.Value, True);
end;

end.

As you can see, defining and setting regions is pretty easy. Look in the help file for in-depth discussions. If you belong to the MS Developer's Network, the library CDs discuss this topic comprehensively.

Change all hyperlinks in a Winword document

Problem/Question/Abstract:

How to change all hyperlinks in a Winword document

Answer:

{ ... }
Doc := Word.ActiveDocument;
for x := 1 to Doc.Hyperlinks.Count do
begin
  Doc.Hyperlinks.Item(x).Address;
end;
{ ... }

How to read the properties of movie files

Problem/Question/Abstract:

Does anybody know how to read properties of movie files (avi, mpeg, asf, ..). I would like to get as much information about files as possible: length, resolution, audio and video codecs, copyright and so on. In other words: Information that is displayed after right-clicking file and selecting "properties".

Answer:

Below is some code to get some of the data. To use the DirectDraw/ DirectShow calls you need either the older DSHOW.PAS (DX6) or more current DirectShow.pas header conversion from the Project JEDI web site:


type
  TDSMediaInfo = record
    SurfaceDesc: TDDSurfaceDesc;
    Pitch: integer;
    PixelFormat: TPixelFormat;
    MediaLength: Int64;
    AvgTimePerFrame: Int64;
    FrameCount: integer;
    Width: integer;
    Height: integer;
    FileSize: Int64;
  end;

function GetHugeFileSize(const FileName: string): int64;
var
  FileHandle: hFile;
begin
  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
  try
    LARGE_INTEGER(Result).LowPart := GetFileSize(FileHandle, @LARGE_INTEGER(Result).HighPart);
    if LARGE_INTEGER(Result).LowPart = $FFFFFFFF then
      Win32Check(GetLastError = NO_ERROR);
  finally
    FileClose(FileHandle);
  end;
end;

function GetMediaInfo(FileName: WideString): TDSMediaInfo;
var
  DirectDraw: IDirectDraw;
  AMStream: IAMMultiMediaStream;
  MMStream: IMultiMediaStream;
  PrimaryVidStream: IMediaStream;
  DDStream: IDirectDrawMediaStream;
  GraphBuilder: IGraphBuilder;
  MediaSeeking: IMediaSeeking;
  TimeStart, TimeStop: Int64;
  DesiredSurface: TDDSurfaceDesc;
  DDSurface: IDirectDrawSurface;
begin
  if FileName = '' then
    raise Exception.Create('No File Name Specified');
  OleCheck(DirectDrawCreate(nil, DirectDraw, nil));
  DirectDraw.SetCooperativeLevel(GetDesktopWindow(), DDSCL_NORMAL);
  Result.FileSize := GetHugeFileSize(FileName);
  AMStream := IAMMultiMediaStream(CreateComObject(CLSID_AMMultiMediaStream));
  OleCheck(AMStream.Initialize(STREAMTYPE_READ, AMMSF_NOGRAPHTHREAD, nil));
  OleCheck(AMStream.AddMediaStream(DirectDraw, MSPID_PrimaryVideo, 0, IMediaStream(nil^)));
  OleCheck(AMStream.OpenFile(PWideChar(FileName), AMMSF_NOCLOCK));
  AMStream.GetFilterGraph(GraphBuilder);
  MediaSeeking := GraphBuilder as IMediaSeeking;
  MediaSeeking.GetDuration(Result.MediaLength);
  MMStream := AMStream as IMultiMediaStream;
  OleCheck(MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream));
  DDStream := PrimaryVidStream as IDirectDrawMediaStream;
  DDStream.GetTimePerFrame(Result.AvgTimePerFrame);
  {Result.FrameCount := Result.MediaLength div Result.AvgTimePerFrame;}
  { TODO : Test for better accuracy }
  Result.FrameCount := Round(Result.MediaLength / Result.AvgTimePerFrame);
  Result.MediaLength := Result.FrameCount * Result.AvgTimePerFrame;
  ZeroMemory(@DesiredSurface, SizeOf(DesiredSurface));
  DesiredSurface.dwSize := Sizeof(DesiredSurface);
  OleCheck(DDStream.GetFormat(TDDSurfaceDesc(nil^), IDirectDrawPalette(nil^),
    DesiredSurface, DWord(nil^)));
  Result.SurfaceDesc := DesiredSurface;
  DesiredSurface.ddsCaps.dwCaps := DesiredSurface.ddsCaps.dwCaps or
    DDSCAPS_OFFSCREENPLAIN or DDSCAPS_SYSTEMMEMORY;
  DesiredSurface.dwFlags := DesiredSurface.dwFlags or DDSD_CAPS or DDSD_PIXELFORMAT;
  {Create a surface here to get vital statistics}
  OleCheck(DirectDraw.CreateSurface(DesiredSurface, DDSurface, nil));
  OleCheck(DDSurface.GetSurfaceDesc(DesiredSurface));
  Result.Pitch := DesiredSurface.lPitch;
  if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 24 then
    Result.PixelFormat := pf24bit
  else if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 32 then
    Result.PixelFormat := pf32bit;
  Result.Width := DesiredSurface.dwWidth;
  Result.Height := DesiredSurface.dwHeight;
end;

List of all ALIASES pointing to a SQL server

Problem/Question/Abstract:

For a little tool, I recently needed to get a list of all aliases which point to a SQL db. (I did not want to see those Paradox files).

Answer:

I came up with the following procedure, which I call like this:

GetAliases(ComboBox1.Items)

procedure GetAliases(const AList: TStrings);
var
  i: Integer;
  Desc: DBDesc;
  Buff: array[0..254] of char;
begin
  // list all BDE aliases
  Session.GetAliasNames(AList);
  for i := AList.Count - 1 downto 0 do
  begin
    StrPCopy(Buff, AList[i]);
    Check(DbiGetDatabaseDesc(Buff, @Desc));
    // no Paradox, please
    if StrPas(Desc.szDBType) = 'STANDARD' then
      AList.Delete(i)
  end
end;

How to change the client area of a TListBox

Problem/Question/Abstract:

I have created my own listbox control as a descendant of TListBox. What I want to be able to do is to change the client area of the listbox so that I can draw a label above the list box area. I can change the client rect by overriding the CreateWnd method like this:

procedure TMyListBox.CreateWnd;
begin
  inherited CreateWnd;
  ClientHeight := Height - 20;
end;

But I can't move the client rect down (ie change the origin). Using ClientOrigin.X := 20 does not work as the ClientOrigin property is read only. I'm thinking maybe I need to override the CreateParams method to do this. Any ideas?

Answer:

You have to respond to the WM_NCCALCSIZE message:

procedure TREDCustomListBox.WMNCCalcSize(var Msg: TWMNCCALCSIZE);
begin
  inherited;
  Inc(MSG.CalcSize_Params^.rgrc[0].Top, FHeader.Height);
end;

That is a the method within my own listbox which does exactly what you want to do. Notice how I'm incrementing the client area by the height of the header (which I implemented as a separate class so I can do the same thing in other controls). It was a fun exercise.

Another clue: You have to paint the header in WM_NCPAINT

How to generate a temporary file name

Problem/Question/Abstract:

I am trying to find a function that will generate a temporary filename. I know that there is the GetTempFilename function, but I don't have any examples on how to use it.

Answer:

Solve 1:

procedure TForm1.Button1Click(Sender: TObject);
var
  TempFile: array[0..MAX_PATH - 1] of Char;
  TempPath: array[0..MAX_PATH - 1] of Char;
begin
  GetTempPath(MAX_PATH, TempPath);
  if GetTempFileName(TempPath, PChar('abc'), 0, TempFile) = 0 then
    raise Exception.Create('GetTempFileName API failed. ' +
      SysErrorMessage(GetLastError));
  ShowMessage(TempFile);
end;

Note that this would actually create the temp file in the windows temp folder. Check online help for GetTempFileName, uUnique parameter for details.


Solve 2:

function MyGetTempFile(const APrefix: string): string;
var
  MyBuffer, MyFileName: array[0..MAX_PATH] of char;
begin
  FillChar(MyBuffer, MAX_PATH, 0');
    FillChar(MyFileName, MAX_PATH, 0);
    GetTempPath(SizeOf(MyBuffer), MyBuffer);
    GetTempFileName(MyBuffer, APrefix, 0, MyFileName);
    Result := MyFileName;
end;

const
  MyPrefix: string = 'abc';

MyTempFile := MyGetTempFile(MyPrefix);


Solve 3:

Pass in the path and filename you want for the first parameter and your extension as the second. If you want the file to always be myfile1.tmp rather than myfile.tmp leave the last parameter, otherwise set it to false. E.g. to create a file like c:\Tempdir\MyTempFile2000.tmp

sNewFileName := CreateNewFileName('C:\TempDir\MyTempFile', '.tmp');

function CreateNewFileName(BaseFileName: string; Ext: string;
  AlwaysUseNumber: Boolean = True): string;
var
  DocIndex: Integer;
  FileName: string;
  FileNameFound: Boolean;
begin
  DocIndex := 1;
  Filenamefound := False;
  {if number not required and basefilename doesn't exist, use that.}
  if not (AlwaysUseNumber) and (not (fileexists(BaseFilename + ext))) then
  begin
    Filename := BaseFilename + ext;
    FilenameFound := true;
  end;
  while not (FileNameFound) do
  begin
    filename := BaseFilename + inttostr(DocIndex) + Ext;
    if fileexists(filename) then
      inc(DocIndex)
    else
      FileNameFound := true;
  end;
  Result := filename;
end;

I simply checks if the file exists and returns the first that doesn't.

How to disable the scrollbars in a TWebBrowser

Problem/Question/Abstract:

How to disable the scrollbars in a TWebBrowser

Answer:

Try this. It also uses 2 speedbuttons to scroll the page.

procedure TForm1.FormShow(Sender: TObject);
begin
  {MUST navigate first}
  {site I created for my baseball league}
  WB.Navigate('http://www.austinmetrobaseball.com');
end;

procedure TForm1.WBDocumentComplete(Sender: TObject; const pDisp: IDispatch;
  var URL: OleVariant);
begin
  {turn off scrollbars}
  while WB.ReadyState <> READYSTATE_COMPLETE do
    Application.ProcessMessages;
  WB.OleObject.document.body.style.overflowX := 'hidden';
  WB.OleObject.document.body.style.overflowY := 'hidden';
end;

procedure TForm1.sbUPClick(Sender: TObject);
begin
  {scrollup 100 pixels}
  WB.OleObject.document.parentWindow.scrollBy(0, -100);
end;

procedure TForm1.sbDNClick(Sender: TObject);
begin
  {scrolldown 100 pixels}
  WB.OleObject.document.parentWindow.scrollBy(0, 100);
end;

How to copy rich text from a TRichEdit to the clipboard

Problem/Question/Abstract:

I have used the TRichEdit component to generate some rich text which I am now holding in a byte array. How can I paste it to the clipboard so that it can be copied into MS Word?

Answer:

You have to copy it to the clipboard with a specific format. The richedit unit defines a string constant CF_RTF (very unfortunate name!). You feed that to RegisterClipboardFormat to obtain a format identifier which you can then use with Clipboard.SetAshandle.

If you write the data to a memorystream you can use the following procedure to copy the streams content to the clipboard. Use the format identifier you obtained from CF_RTF as first parameter.

procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);
var
  hMem: THandle;
  pMem: Pointer;
begin
  {Rewind stream position to start}
  S.Position := 0;
  {Allocate a global memory block the size of the stream data}
  hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);
  if hMem <> 0 then
  begin
    {Succeeded, lock the memory handle to get a pointer to the memory}
    pMem := GlobalLock(hMem);
    if pMem <> nil then
    begin
      {Succeeded, now read the stream contents into the memory the pointer points at}
      try
        S.Read(pMem^, S.Size);
        {Rewind stream again, caller may be confused if the stream position is
                                left at the end}
        S.Position := 0;
      finally
        {Unlock the memory block}
        GlobalUnlock(hMem);
      end;
      {Open clipboard and put the block into it. The way the Delphi clipboard
                        object is written this will clear the clipboard first. Make sure the
                        clipboard is closed even in case of an exception. If left open it would
                        become unusable for other apps.}
      Clipboard.Open;
      try
        Clipboard.SetAsHandle(fmt, hMem);
      finally
        Clipboard.Close;
      end;
    end
    else
    begin
      {Could not lock the memory block, so free it again and raise an out of
                        memory exception}
      GlobalFree(hMem);
      OutOfMemoryError;
    end;
  end
  else
    {Failed to allocate the memory block, raise exception}
    OutOfMemoryError;
end;

Files Bigger than 2 gig

Problem/Question/Abstract:

Searching for files and get no problems when the size is greater than 2 gig

Answer:

The FindFirstFile / FindNextFile / FindClose APIs are used for searching for various files.

When using these APIs it is important to remember that failing to close a Find can result in files or directories not being available for some operations (such as deletes). This is because these APIs open a handle to the objects being searched, and the operating system won't allow you to do certain things to an object as long as an active handle to that object exists.  

Also, the data structure used by these APIs contains string data, which is terminated by null characters.

Example:

procedure TForm1.Button1Click(Sender: TObject);
var
  Handle: THandle;
  s: string;
  FD: WIN32_FIND_DATA;
begin
  s := 'c:\*.*';
  Handle := FindFirstFile(pchar(s), fd);
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    Memo1.Lines.Add(fd.cFileName);
    while FindNextFile(handle, fd) = True do
      Memo1.Lines.Add(fd.cFileName);
  end;
  Windows.FindClose(Handle);
end;

Finds the first file matching the wild file specifier. '*' can be used to match 0 or more characters, '?' for a single character. If there are no wild specifiers in the string the function acts as a query for an explicit single file. The function works for both files and folders.
The WIN32_FIND_DATA contains full information about the first matched file.

dwFileAttributes File attributes (see CreateFile)
ftCreationTime Time file created (see GetFileTime)
ftLastAccessTime Time file last accessed
ftLastWriteTime Time file last written to
nFileSizeHigh Most significant 32bits of file size(see GetFileSize)
nFileSizeLow Least significant 32bits of file size
dwReserved0 O.S. specific data
dwReserved1 O.S. specific data
cFileName File name with extension within the folder
cAlternateFileName Alternate shortened (8.3) form of name iff cFileName is not a valid MSDOS name

The returned handle is passed to FindNextFile to get at the next matching file or folder. When the scan is completed FindClose must be used to close the handle.

More Info:

WIN32_FIND_DATA = record
  dwFileAttributes: DWORD;
  ftCreationTime: TFileTime;
  ftLastAccessTime: TFileTime;
  ftLastWriteTime: TFileTime;
  nFileSizeHigh: DWORD;
  nFileSizeLow: DWORD;
  dwReserved0: DWORD;
  dwReserved1: DWORD;
  cFileName: array[0..MAX_PATH - 1] of AnsiChar;
  cAlternateFileName: array[0..13] of AnsiChar;
end;

FILE_ATTRIBUTE_ARCHIVE
The file is an archive file. Applications use this value to mark files for     backup or removal.

FILE_ATTRIBUTE_COMPRESSED
The file or directory is compressed. For a file, this means that all of the data in the file is compressed. For a directory, this means that compression is the default for newly created files and subdirectories.

FILE_ATTRIBUTE_DIRECTORY
The file is a directory.

FILE_ATTRIBUTE_HIDDEN
The file is hidden. It is not included in an ordinary directory listing.

FILE_ATTRIBUTE_NORMAL
The file has no other attributes set. This value is valid only if used alone.

FILE_ATTRIBUTE_OFFLINE
The data of the file is not immediately available. Indicates that the file data has been physically moved to offline storage.

FILE_ATTRIBUTE_READONLY
The file is read-only. Applications can read the file but cannot write to it or delete it.

FILE_ATTRIBUTE_SYSTEM
The file is part of the operating system or is used exclusively by it.

FILE_ATTRIBUTE_TEMPORARY
The file is being used for temporary storage. Applications should write to the file only if absolutely necessary. Most of the file's data remains in memory without being flushed to the media because the file will soon be deleted.

How to set the item index in an alpha sorted TComboBox when searching incrementally

Problem/Question/Abstract:

I have some alpha sorted items in a combo box (style csDropDown). When the user types in text, the combo box incrementally searches but it does not set the itemindex property. Is there a way of making it do this?

Answer:

You could use the OnChange handler to perform a CB_FINDSTRING with the current edit text, then set the itemindex to the found item. But that is disruptive to typing, if the found item is not the one the user wants he has no way to change it, since each change triggers OnChange, which again finds the item. So you have to invest considerably more effort into this. Attach these handlers to the OnKeyPress and the OnChange event of the combobox, that seems to work fairly well.

procedure TForm1.ComboBox1Change(Sender: TObject);
var
  oldpos: Integer;
  item: Integer;
begin
  with sender as TComboBox do
  begin
    oldpos := selstart;
    item := Perform(CB_FINDSTRING, -1, lparam(Pchar(text)));
    if item >= 0 then
    begin
      onchange := nil;
      text := items[item];
      selstart := oldpos;
      sellength := gettextlen - selstart;
      onchange := combobox1change;
    end;
  end;
end;

procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char);
var
  oldlen: Integer;
begin
  if key = #8 then
    with sender as TComboBox do
    begin
      oldlen := sellength;
      if selstart > 0 then
      begin
        selstart := selstart - 1;
        sellength := oldlen + 1;
      end;
    end;
end;

This works with Win2000, but on a Win98 machine, the ItemIndex is getting set incorrectly after the first search. To make it work under both Win2000 and Win98, you could do something like this:

procedure TMainForm.ComboBoxKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
  s: string;
begin
  if key = VK_RETURN then
  begin
    s := TComboBox(Sender).Text;
    {The search doesn't work in Win 98 with DroppedDown set to true}
    TComboBox(Sender).DroppedDown := false;
    TComboBox(Sender).Text := s;
  end;
end;

Disable the transparent part of a TSpeedButton from clicking

Problem/Question/Abstract:

How to disable the transparent part of a TSpeedButton from clicking

Answer:

procedure TMFSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
var
  ScreenDC: HDC;
  Transp, Bits: Boolean;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    Bits := False;
    Transp := False;
    ScreenDC := GetDC(0);
    try
      {Transparent color is color of form background. Test for True Color 24bit
                  or  more, because on lower color depth the color is blended, so it works only
                        on true color for some colors. If it is for example clBlack, it works
                        on everything}
      Bits := GetDeviceCaps(ScreenDC, BITSPIXEL) >= 24;
      {test for desired color}
      Transp := GetPixel(ScreenDC, Mouse.CursorPos.x, Mouse.CursorPos.Y) = $0094ADBD;
    finally
      ReleaseDC(0, ScreenDC);
    end;
    {leave procedure if test for transp. color was successful}
    if Transp and Bits then
      Exit;
    if not FDown then
    begin
      FState := bsDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;

Starting Delphi without a project

Problem/Question/Abstract:

Starting Delphi without a project

Answer:

Does it disturb you that the Delphi IDE starts up with the a 'noname project'?

There is help. Run Delphi with passing the -np switch. That will open it without a project. You could put this parameter in your shortcut that you use to start up the IDE.

\Delphi5\bin\Delphi32.exe -np

How to display the item text of a TListBox in the hint window of the listbox

Problem/Question/Abstract:

I would like to have my hints read the same as the listbox item that the mouse is pointing to. How can I do that?

Answer:

Solve 1:

You could use the listboxes OnMOuseMove event together with the ItemAtPos method.


procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  item: Integer;
begin
  with Sender as TListbox do
  begin
    item := itemAtpos(Point(x, y), true);
    if item >= 0 then
    begin
      if hint <> items[item] then
      begin
        hint := items[item];
        application.cancelhint;
      end;
    end;
  end;
end;


Solve 2:

You can use the OnMouseMove event and trap which item is under the cursor.

procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  APoint: TPoint;
  Index: Integer;
begin
  APoint.X := X;
  APoint.Y := Y;
  Index := ListBox1.ItemAtPos(APoint, True);
  if Index >= 0 then
  begin
    ListBox1.Hint := ListBox1.Items.Strings[Index];
  end;
end;

If you want to Hint to change when the mouse moves after the hint is originally shown, you might want to do something like this:

Set the ShowHint property of the list box to False.


procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  APoint: TPoint;
  Index: Integer;
  HW: THintWindow;
  Rec: TRect;
  sHint: string;
begin
  APoint.X := X;
  APoint.Y := Y;
  Index := ListBox1.ItemAtPos(APoint, True);
  if Index >= 0 then
  begin
    HW := THintWindow.Create(nil);
    try
      GetCursorPos(APoint);
      sHint := ListBox1.Items.Strings[Index];
      Rec.Top := APoint.Y + 20;
      Rec.Left := APoint.X;
      Rec.Right := Rec.Left + HW.Canvas.TextWidth(sHint) + 6;
      Rec.Bottom := Rec.Top + HW.Canvas.TextHeight(sHint) + 4;
      HW.ActivateHint(Rec, sHint);
      HW.Refresh;
      Sleep(1000);
      HW.ReleaseHandle;
    finally
      HW.Free;
    end;
  end;
end;

How to get the icon of a window for which you know the handle

Problem/Question/Abstract:

How to get the icon of a window for which you know the handle

Answer:

Solve 1:

function GetWindowIcon(Wnd: HWND): TIcon;
{Wnd: Handle to window whose icon you want
Returns: TIcon instance holding the window's icon}
begin
  {Create a TIcon instance to hold the icon information}
  Result := TIcon.Create;
  {As the Win32 API help states, getclasslong will return the handle to the window's icon. Assign that value to the TIcon's Handle property as described in the VCL help.}
  Result.Handle := GetClassLong(Wnd, GCL_HICON);
end;

Additional note:
In my opinion, memory should be allocated and freed on the same level (if possible). So I would recommend changing the above code to this:

procedure GetWindowIcon(Wnd: HWND; Icon: TIcon);
begin
  if not Assigned(Icon) then
    raise Exception.Create('Create instance of Icon ' + 'before calling GetWindowIcon')
      Icon.Handle := GetClassLong(Wnd, GCL_HICON);
end;


Solve 2:

Use GetClassLong to obtain the icon handle and then use CopyIcon to create a new icon from this icon handle. Assuming the Delphi help is open for testing, following are examples:

{Returns true if icon is retrieved and copied to AIcon succesfully}

function CopyIconFromWindowHandle(AHandle: THandle; AIcon: TIcon): boolean;
var
  hWindowIcon: THandle; {HICON}
  tmpIcon: TIcon; {temporary TIcon}
begin
  Result := true;
  if (not (AHandle > 0)) or (AIcon = nil) then
  begin
    Result := false;
    exit;
  end;
  hWindowIcon := GetClassLong(AHandle, GCL_HICON);
  if hWindowIcon = 0 then
  begin
    Result := false;
    exit;
  end;
  tmpIcon := TIcon.Create;
  try
    {exactly the same icon is copied}
    tmpIcon.Handle := CopyIcon(hWindowIcon);
    if tmpIcon.Handle = 0 then
    begin
      Result := false;
      exit;
    end;
    {AIcon is changing}
    try
      AIcon.Assign(tmpIcon);
    except
      Result := false;
      raise;
    end
  finally
    tmpIcon.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wHandle: THandle;
  TestIcon: TIcon;
begin
  wHandle := FindWindow(nil, pchar('Delphi Help'));
  if not (wHandle > 0) then
    exit;
  TestIcon := TIcon.Create;
  try
    TestIcon.Handle := CopyIcon(Application.Icon.Handle);
    Canvas.Draw(0, 0, TestIcon);
    if CopyIconFromWindowHandle(wHandle, TestIcon) = true then
      Canvas.Draw(0, 80, TestIcon);
  finally
    TestIcon.Free;
  end;
end;

Find out which language version of Word is installed

Problem/Question/Abstract:

How can I get the language of an Office installation? I need to add a new menu item, but the captions are Office language dependent (File - English, Archivo - Spanish, etc. )

Answer:

{ ... }
MsWord := CreateOleObject('Word.Basic');
try
  {Return Application Info. This call is the same for English and
        French Microsoft Word.}
  Lang := MsWord.AppInfo(Integer(16));
except
  try
    {For German Microsoft Word the procedure name is translated}
    Lang := MsWord.AnwInfo(Integer(16));
  except
    try
      {For Swedish Microsoft Word the procedure name is translated}
      Lang := MsWord.PrgmInfo(Integer(16));
    except
      try
        {For Dutch Microsoft Word the procedure name is translated}
        Lang := MsWord.ToepasInfo(Integer(16));
      except
        {If this procedure does not exist there is a different translation
                          of Microsoft Word}
        ShowMessage('Microsoft Word version is not German, French, Dutch, Swedish
                                 or English.');
        Exit;
      end;
    end;
  end;
end;
ShowMessage(Lang);
{ ... }