How to remove the scrollbar of a TListBox

Problem/Question/Abstract:

I want to remove the scrollbar of a TListBox and control scrolling with a separate scrollbar. Anyone has an idea how to remove it?

Answer:

This requires a somewhat dubious hack. Derive a new component from TListBox, like this:


type
  TNoVScrolllistbox = class(TListBox)
  private
    procedure WMNCCalcSize(var msg: TMessage); message WM_NCCALCSIZE;
  end;

procedure TNoVScrolllistbox.WMNCCalcSize(var msg: TMessage);
var
  style: Integer;
begin
  style := GetWindowLong(handle, GWL_STYLE);
  if (style and WS_VSCROLL) <> 0 then
    SetWindowLong(handle, GWL_STYLE, style and not WS_VSCROLL);
  inherited;
end;


This technique works for nearly any control that uses the standard window scrollbars.

Create a balloon-shaped tooltip

Problem/Question/Abstract:

How to create a balloon-shaped tooltip

Answer:

Solve 1:

You could show a ToolTip control, which would have the appearance of a cartoon "balloon", with rounded corners and a stem pointing to the item. Also, there could be a multiline text and a caption with an icon. But in order to see this, be sure that there are Version 5.80 of Comctl32.dll and version 5.0 of Shlwapi.dll installed on your machine. Below is the code which would force the tooltip to show itself.

{ ... }
var
  FTTHandle: THandle;

const
  TTM_SETTITLE = $0420;
  TTS_BALLOON = $040;

procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  ti: TOOLINFO;
  XRect: TRect;
begin
  FTTHandle := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, WS_POPUP or
    TTS_NOPREFIX or TTS_BALLOON, 0, 0, 0, 0, Handle, 0, Application.Handle, nil);
  ti.cbSize := sizeof(TOOLINFO);
  ti.uFlags := TTF_SUBCLASS or TTF_DI_SETITEM;
  ti.hwnd := Handle;
  ti.hinst := Application.Handle;
  ti.uId := 0;
  ti.lpszText := 'First line' + #$0D#$0A + 'Second line' + #$0D#$0A + {...}
                + 'Last Line';
  {ti.lpszText := LPSTR_TEXTCALLBACK;}
  XRect := ClientRect;
  ti.rect.left := XRect.left;
  ti.rect.top := XRect.top;
  ti.rect.right := XRect.right;
  ti.rect.bottom := XRect.bottom;
  SendMessage(FTTHandle, TTM_ADDTOOL, 0, integer(@ti));
  SendMessage(FTTHandle, TTM_SETTITLE, 1, integer(PChar('Title')));
  SendMessage(FTTHandle, TTM_SETMAXTIPWIDTH, 0, 100);
  SendMessage(FTTHandle, TTM_SETTIPBKCOLOR, clMoneyGreen, 0);
  SendMessage(FTTHandle, TTM_SETTIPTEXTCOLOR, clNavy, 0);
end;

Basically, you could even perform some custom painting on the tooltip's surface. In order to do this add a WM_NOTIFY message handler to the form and handle the NM_CUSTOMDRAW notification. Below is an example:

{ ... }
type
  TForm1 = class(TForm)
    SpeedButton2: TSpeedButton;
    procedure SpeedButton2Click(Sender: TObject);
  protected
    procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  end;

  { ... }

procedure TForm1.WMNotify(var Message: TWMNotify);
var
  XCanvas: TCanvas;
  XRect: TRect;
begin
  inherited;
  if integer(Message.NMHdr.hwndFrom) = integer(FTTHandle) then
  begin
    case Message.NMHdr.code of
      TTN_POP:
        begin
          {do something here, when tooltip hides}
        end;
      TTN_SHOW:
        begin
          {do something here, when tooltip show itself}
        end;
      TTN_NEEDTEXT:
        begin
          PTOOLTIPTEXT(Message.NMHdr).lpszText := 'some text...';
          {here you could set new text to the tooltip, but only in
                                        case you've specified a LPSTR_TEXTCALLBACK constant
                                        in the lpszText identifier, in the SpeedButton2Click method}
        end;
      NM_CUSTOMDRAW:
        begin
          with PNMCustomDraw(Message.NMHdr)^ do
          begin
            if dwDrawStage = CDDS_PREPAINT then
            begin
              Message.Result := CDRF_NOTIFYPOSTPAINT;
            end
            else if dwDrawStage = CDDS_POSTPAINT then
            begin
              XCanvas := TCanvas.Create;
              try
                XCanvas.Handle := hdc;
                XRect := PNMCustomDraw(Message.NMHdr)^.rc;
                XRect.Left := XRect.Right - 40;
                XRect.Bottom := XRect.Top + 30;
                XCanvas.Brush.Color := clBlue;
                XCanvas.FillRect(RECT(XRect.Left, XRect.Top, XRect.Right,
                                                                        XRect.Top + 15));
                XCanvas.Brush.Color := clYellow;
                XCanvas.FillRect(RECT(XRect.Left, XRect.Top + 15,
                                                                        XRect.Right, XRect.Top + 30));
                XCanvas.Brush.Color := clBlack;
                XCanvas.FrameRect(XRect);
              finally
                XCanvas.Free;
              end;
            end;
          end;
        end;
    end;
  end;
end;


Solve 2:

unit Unit1;

interface

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

const
  TTS_BALLOON = $40;
  TTM_SETTITLE = (WM_USER + 32);

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

var
  Form1: TForm1;
  hTooltip: Cardinal;
  ti: TToolInfo;
  buffer: array[0..255] of char;

implementation

{$R *.dfm}

procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst := hInstance;
  end;
end;

procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title:
  PChar);
var
  Item: THandle;
  Rect: TRect;
begin
  Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then
  begin
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, sizeof(buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then
      IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateToolTips(Form1.Handle);
  AddToolTip(Memo1.Handle, @ti, 1, Memo1.Lines.GetText, 'Memo Text');
end;

end.

Accept files dragged over an application

Problem/Question/Abstract:

If you have an application that works with files, you probably want that users would be able to drag and drop files over your application to open them.

Answer:

For your application be able to accept files when dropped over it, you need to tell windows that your application can accept files. To do this, you have two options:

Make use of Params.ExStyle
  
To be able to accept files without much trouble you have just to override the protected the protected procedure CreateParams and write the following:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  // Register the window to be able to accept dropped files
  Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES;
end;

Use API function DragAcceptFiles
  
The other option is use DragAcceptFiles API function. This way you can control if your application can accept dropped files or not without the need to change Params.ExStyle

Both options of activation activate the WM_DROPFILES windows message, and it's here that you'll have to process the dropped files.

The following routine gives the essential part of what you need to do:

procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
// The WM_DROPFILES message is sent when the user releases the left mouse button
//    while the cursor is in the window of an application that has registered
//    itself as a recipient of dropped files.
var
  FNumFiles: Integer;
  i: Integer;
  BufSize: Integer;
  FFilePath: array of char;
  FFileName: string;

begin
  // How many files were dropped ?
  FNumFiles := DragQueryFile(Message.Drop, $FFFFFFFF, nil, 0);
  // Process all files in the list
  for i := 0 to FNumFiles - 1 do
  begin
    // Get the buffer size to old the filename
    BufSize := DragQueryFile(Message.Drop, i, nil, 0);
    // Get filename. This filename is a null-terminated string.
    SetLength(FFilePath, BufSize + 1);
    DragQueryFile(Message.Drop, i, PChar(FFilePath), BufSize + 1);
    // Check if the dropped file extension can be accepted
    FFileName := ExtractFileName(PChar(FFilePath));

    // DO WHATEVER YOU NEED
  end;
  // The DragFinish function releases memory that Windows allocated for use in
  //    transferring filenames to the application.
  DragFinish(Message.Drop);
end;

Attached is a project sample. It's a small file text viewer and it implement's a bit more than the above, as you can see in the following screen shot.

Detect a form movement

Problem/Question/Abstract:

How to detect a form movement

Answer:

Solve 1:

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE;
    procedure WMENTERSIZEMOVE(var Message: TMessage); message WM_ENTERSIZEMOVE;

implementation

procedure TForm1.WMENTERSIZEMOVE(var Message: TMessage);
begin
  Form1.Caption := 'Starting moving and sizing';
end;

procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
  Form1.Caption := 'Finished moving and sizing';
end;


Solve 2:

Handle the WM_MOVING or WM_WINDOWPOSCHANGING message from windows, i.e.:

{ Private declarations }

procedure WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
  message WM_WINDOWPOSCHANGING;

procedure TForm1.WMWINDOWPOSCHANGING(var msg: TWMWINDOWPOSCHANGING);
var
  r: TRect;
begin
  if ((SWP_NOMOVE or SWP_NOSIZE) and msg.WindowPos^.flags) <> (SWP_NOMOVE
    or SWP_NOSIZE) then
  begin
    { Window is moved or sized, get usable screen area }
    { Do something here }
  end;
  inherited;
end;

Copy a file using a TFileStream

Problem/Question/Abstract:

How to copy a file using a TFileStream

Answer:

{ ... }
type
  TFileCopyUpdateEvent = procedure(const SrcFile, DestFile: string;
    CurrentPos, MaxSize: Integer) of object;

function Min(Val1, Val2: Integer): Integer;
begin
  Result := Val1;
  if Val2 < Val1 then
    Result := Val2;
end;

{SrcFile and DestFile are the fully qualified filenames to the files to copy function}

MyFileCopy(SrcFile, DestFile: TFilename; OnUpdate: TFileCopyUpdateEvent = nil):
  Boolean;
const
  StreamBuf = 4096;
var
  Src, Dst: TFileStream;
  BufCount: Integer;
begin
  Src := nil;
  Dst := nil; {prevents .Free problems on exception}
  {allow everyone else any access}
  Src := TFileStream.Create(SrcFile, fmOpenRead or fmShareDenyNone);
  if FileExists(DestFile) then
    {this could cause an error if a user has the file open}
    Dst := TFileStream.Create(DestFile, fmOpenWrite or fmShareExclusive)
  else
    Dst := TFileStream.Create(DestFile, fmCreate or fmShareExclusive);
  try
    while Dst.Position < Dst.Size do
    begin
      BufCount := Min(StreamBuf, Dst.Size - Dst.Position);
      Src.CopyFrom(Dst, BufCount);
      if Assigned(OnUpdate) then {report progress every 4k}
        OnUpdate(SrcFile, DestFile, Dst.Position, Dst.Size);
    end;
  finally
    Src.Free;
    Dst.Free;
  end;
end;

Extract swf from Flash Projector (EXE)

Problem/Question/Abstract:

How to extract swf from Flash Projector

Answer:

procedure ExeToSWF(ExeFile, aSWF: string);
var
  p: pointer;
  f: file;
  sz,
    swfsize: integer;
const
  SWF_FLAG: integer = $FA123456;
begin
  if not fileexists(ExeFile) then
  begin
    messagebox(Application.Handle, pchar('File not found'), pchar('Error'),
      MB_ICONERROR);
    exit;
  end;
  assignfile(f, ExeFile);
  reset(f, 1);
  seek(f, filesize(f) - (2 * sizeof(integer)));
  blockread(f, sz, sizeof(integer));
  if sz <> swf_flag then
  begin
    messagebox(Application.Handle, pchar('Not a valid Projector Exe'), pchar('Error'),
      MB_ICONERROR);
    closefile(f);
    exit;
  end;
  blockread(f, swfsize, sizeof(integer));
  seek(f, filesize(f) - (2 * sizeof(integer)) - swfsize);
  getmem(p, swfsize);
  blockread(f, p^, swfsize);
  closefile(f);
  assignfile(f, aSWF);
  rewrite(f, 1);
  blockwrite(f, p^, swfsize);
  closefile(f);
  freemem(p, swfsize);
  messagebox(Application.Handle, pchar('SWF Extracted'), pchar('Succes'),
    MB_ICONINFORMATION);
end;

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExeToSWF('C:Desktopflash.exe', 'C:Desktopf.swf');
end;

end.

Undocumented: Delphi Visual Component Library Access License

Problem/Question/Abstract:

Undocumented: Delphi Visual Component Library Access License

Answer:

The SysUtils.pas unit contains some very interesting routines that are used by the VCL components to check if the correct version of Delphi is beeing used to compile the code (e.g. C/S components won't run if compiled with the Pro compiler).

Here are the functions:

function GDAL: LongWord;

Get Delphi Access License. Retreives the access licences resource. It checks if it is valid, if not an exception with the message 'Application is not licensed to use this feature' is raised.
The returned value is the decrypted first Access Licence (AL1).

procedure RCS;

Perform a check to see there is a Delphi Client Server licence. An exception is raised if the license is not valid.

procedure RPR;

Perform a check to see there is a Delphi Pro licence. An exception is raised if the license is not valid.

Other non exposed functions are:

function AL1(const P): LongWord;
function AL2(const P): LongWord;

These two functions return the decrypted value of the license value specified by P.

procedure ALV;

Raises an Access Licence Violation exception.

function ALR: Pointer;

Access License Resource loader. Returns a pointer to the loaded access license. An exception is raised if the resource is not found.

Convert short file names to long ones

Problem/Question/Abstract:

How do I convert a short (alias) filename or directory name into its long equivalent?

Answer:

Solve 1:

{Parameters:

shortname:
File name or path to convert. This can be a fully qualified file name or a path relative to the current directory. It can contain long and / or short forms for the names.

Returns:
Fully qualified filename using the long names for all elements of the path.

Description:
Recursively uses FindFirst to find the long names for the path elements.

Error Conditions:
Will raise an exception if any part of the path was not found.

Created:
15.01.98 14:09:26 by Peter Below}

function GetLongFilename(shortname: string): string;

  function GetL(shortname: string): string;
  var
    srec: TSearchRec;
  begin
    { Lob off the last element of the passed name. If we received only a root name,
    e.g. c:\, ExtractFileDir returns the path unchanged. }
    Result := ExtractFileDir(shortname);
    if (Result <> shortname) then
    begin
      { We still have an unconverted path element. So convert the last one in
                  the current shortname and combine the resulting long name with what we get
                        by calling ourselves recursively with the rest of the path. }
      if FindFirst(shortname, faAnyfile, srec) = 0 then
      try
        Result := GetL(Result) + '\' + srec.Name;
      finally
        FindClose(srec);
      end
      else
        raise Exception.CreateFmt('Path %s does not exist!', [shortname]);
    end
    else
      { Only the root remains. Remove the backslash since the caller will add it
                  back anyway. }
      Delete(Result, length(result), 1);
  end;

begin
  { Create fully qualified path and pass it to the converter. }
  Result := GetL(ExpandFilename(shortname));
end;


Solve 2:

{Get LFN from 8.3}

function GetLongPathName(const PathName: string): string;
var
  Drive: string;
  Path: string;
  SearchRec: TSearchRec;
begin
  if PathName = '' then
    Exit;
  Drive := ExtractFileDrive(PathName);
  Path := Copy(PathName, Length(Drive) + 1, Length(PathName));
  if (Path = '') or (Path = '\') then
  begin
    Result := PathName;
    if Result[Length(Result)] = '\' then
      Delete(Result, Length(Result), 1);
  end
  else
  begin
    Path := GetLongPathName(ExtractFileDir(PathName));
    if FindFirst(PathName, faAnyFile, SearchRec) = 0 then
    begin
      Result := Path + '\' + SearchRec.FindData.cFileName;
      FindClose(SearchRec);
    end
    else
      Result := Path + '\' + ExtractFileName(PathName);
  end;
end;


Solve 3:

You could try the following. It should work on Win95 and above.

unit WhateverYouWantToCallIt;

interface

function LongPathFromShort(const ShortPath: string): string;

implementation

uses
  Windows, SysUtils, ActiveX, ShlObj;

function LongPathFromShort(const ShortPath: string): string;
var
  iAttributes: Cardinal;
  iEaten: Cardinal;
  IntfDesktop: IShellFolder;
  IntfMalloc: IMalloc;
  pItemList: PItemIDList;
  sFile: WideString;
  szFile: array[0..MAX_PATH] of Char;
begin
  Result := ShortPath;
  if not FileExists(ShortPath) then
    Exit;
  if Succeeded(SHGetDesktopFolder(IntfDesktop)) then
  begin
    sFile := ShortPath;
    iAttributes := 0;
    if Succeeded(IntfDesktop.ParseDisplayName(0, nil, POleStr(sFile),
      iEaten, pItemList, iAttributes)) then
    begin
      SHGetPathFromIDList(pItemList, szFile);
      Result := szFile;
      SHGetMalloc(IntfMalloc);
      IntfMalloc.Free(pItemList)
    end
  end
end;

end.


Solve 4:

GetFullPathName converts a relative path to an absolute path. You can use GetLongPathName, but this requires Win98 and later or Win2k and later.

function GetLongName(const APath: string): string;
var
  Buffer: array[0..MAX_PATH] of Char;
  Required: Integer;
begin
  Required := GetLongPathName(PChar(APath), Buffer, Length(Buffer));
  if Required > MAX_PATH then {Buffer too small}
  begin
    SetLength(Result, Required - 1);
    GetLongPathName(PChar(APath), Pointer(Result), Required);
  end
  else if Required = 0 then {Error}
    Result := APath
  else
    SetString(Result, Buffer, Required);
end;

For an ANSI only function you can reduce the above to:

function GetLongName(const APath: AnsiString): AnsiString;
var
  Buffer: array[0..MAX_PATH] of AnsiChar;
  Required: Integer;
begin
  Required := GetLongPathNameA(PChar(APath), Buffer, Length(Buffer));
  SetString(Result, Buffer, Required);
end;

If you need to support for Win95 or WinNT, you can use this function:

function GetLongPathName(Path: string): string;
var
  I: Integer;
  SearchHandle: THandle;
  FindData: TWin32FindData;
  IsBackSlash: Boolean;
begin
  Path := ExpandFileName(Path);
  Result := ExtractFileDrive(Path);
  I := Length(Result);
  if Length(Path) <= I then {only drive}
    Exit;
  if Path[I + 1] = '\' then
  begin
    Result := Result + '\';
    Inc(I);
  end;
  Delete(Path, 1, I);
  repeat
    I := Pos('\', Path);
    IsBackSlash := I > 0;
    if not IsBackSlash then
      I := Length(Path) + 1;
    SearchHandle := FindFirstFile(PChar(Result + Copy(Path, 1, I - 1)), FindData);
    if SearchHandle <> INVALID_HANDLE_VALUE then
    begin
      try
        Result := Result + FindData.cFileName;
        if IsBackSlash then
          Result := Result + '\';
      finally
        Windows.FindClose(SearchHandle);
      end;
    end
    else
    begin
      Result := Result + Path;
      Break;
    end;
    Delete(Path, 1, I);
  until Length(Path) = 0;
end;

Gauge in a StatusBar

Problem/Question/Abstract:

How to put a component in a statusbar?

Answer:

uses Gauges
  { ... }

  public
  Gauge1: TGauge;
private
{ ... }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Gauge1 := TGauge.Create(StatusBar1); //Ctreate it on the statusbar
  Gauge1.Parent := StatusBar1; //Parent Winodow
  Gauge1.Height := StatusBar1.Height - 6; //Height
  Gauge1.Top := 4; //Top
  Gauge1.BackColor := clSilver; //Make it cool
  Gauge1.BorderStyle := bsNone; //Border
  Gauge1.ForeColor := clRed; //Color of Gauge
  Gauge1.Left := StatusBar1.Width div 2; //Left Position
  Gauge1.Progress := 0; //Progress
end;

Subclassing Non Delphi Windows

Problem/Question/Abstract:

How to subclass non Delphi windows

Answer:

Every window has a procedure associated with it that recieves all the messages that are sent to it. To subclass a window means to replace the procedure associated with the window by another user defined procedure. The main use of subclassing windows is to customize how a window works.

The handle of the procedure associated with the window can be got by calling the GetWindowLong function.

hproc: TFarproc;
hproc := TFarProc(GetWindowLong(hwnd, GWL_WNDPROC));

if hwnd is the handle of the function then hproc is the handle of the procedure associated with the window.

Now define a procedure that will replace the original procedure associated with the window.

For example see the code below.

type
  TForm1 = class(TForm)
  private
    hproc: TFarproc;
  protected
    procedure WndProc(var msg: TMessage);
  end;

Here the procedure WndProc will replace the original window procedure.

To replace the original procedure with the procedure WndProc you have to first call the function 'MakeObjectInstance'  defined in forms unit which converts a member procedure(Here WndProc is member of TForm1 class) to a standard procedure.

This is because the WndProc procedure is a member function and Windows does not understand class member functions.  Class member functions have a "self" pointer as a hidden first parameter which uniquely identifies a class object (keep in mind that an object is a specific instantiation of a class). The API callback does not know how to pass "self".

To convert the member procedure to a standard procedure call the MakeObjectInstance function as shown below.

fproc: TFarProc;
fproc := MakeObjectInstance(WndProc);

after you have done this

call the SetWindowlong function to replace the procedure of the window as shown below

SetWindowlong(hwnd, GWL_WNDPROC, longword(fcurProc));

Now all messages that are sent to the window will be intercepted by the WndProc procedure

The messages that are not handled by the WndProc can be sent to the original procedure by using the CallWindowProc function.

Here is how to call the function.

procedure TForm1.DlgProc(var msg: Tmessage);
begin
  case msg.msg of
    WM_SIZE:
      begin
        //user defined code
      end;
    WM_PAINT:
      begin
        //user defined code
      end;
  end;
  //all unhandled messages are sent to original procedure. Here  hproc is the  
        //handle to the original window procedure.
  msg.result := CallWindowProc(hproc, hwnd, msg.msg, msg.wparam, msg.lparam);
end;

once you have finshed you have to destroy the handle created by the MakeObjectInstance(WndProc) function by calling the 'FreeObjectInstance' function which is also defined in the forms unit. You usually call this function when the form is closed. Example of how to call the function is shown below.

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeObjectInstance(fproc);
end;

Enumerate MS-SQL Servers via SQL-DMO into TStrings

Problem/Question/Abstract:

Function to load a StringList with MS-SQL Servers on a Network via SQL-DMO. MS-SQL DMO is a COM/OLE object that can do many things, in this article we just enumerate the SQL Servers on a Network. "List SQL servers on the network" by Tommy Andersen deals with this issue by using WinSock and a comment supplies a solution using CoApplication.Create. This article solves the issue by using CreateOleObject('SQLDMO.SQLServer'). The function returns true if successful.

// Declaration

function EnumSqlServers(AStrings: TStrings): boolean;

// Eg.
EnumSqlServers(Memo1.Lines);

Answer:

uses ComObj, Variants; {Variants is for Delphi 7}

// ====================================================
// Load SQL Servers on a Network into a string list
// ====================================================

function EnumSqlServers(AStrings: TStrings): boolean;
var
oDmo, oApp, oServers: OleVariant;
bResult: boolean;
i: integer;
begin
AStrings.Clear;

try
oDMO := CreateOleObject('SQLDMO.SQLServer');
oApp := oDMO.Application;
oServers := oApp.ListAvailableSQLServers;

try
AStrings.BeginUpdate;
for i := 1 to oServers.Count do
AStrings.Add(oServers.Item(i));
finally
AStrings.EndUpdate;
end;

bResult := true;
except
bResult := false;
end;

oServers := Unassigned;
oApp := Unassigned;
oDMO := Unassigned;

Result := bResult;
end;

Where is Delphi installed? What is $(DELPHI)?

Problem/Question/Abstract:

Where is Delphi installed? What is $(DELPHI)?

Answer:

In Delphi, when specifying search paths, you can use $(delphi) to refer to Delphi's installation directory.
If your are writing an installation program, you may be interested in how to find out, where / which version of Delphi is installed.

It is in the registry at:
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\3.0
or
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\4.0

Adding a EXE file into yours and running it

Problem/Question/Abstract:

How can I put an EXE file into my application and run it?

Answer:

1) Create file "hearts.rc"

2) Insert following text in that file:
   "TESTFILE EXEFILE \Mshearts.exe"
   Mshearts.exe -> Mshearts from Windows

3) Compile this file with brcc32.exe, which is located in your
   "\Borland\Delphi\Bin" directory by writing
   following command: "brcc32 -32 \hearts.rc"

Now you should have file "hearts.RES". How to add it to your application:

1) Copy "hearts.RES" to your project directory

2) Add ShellApi to USES
   To global vars add "Hearts:String";
   Next add to project:

{$R HEARTS.RES}

function GetTempDir: string;
var
  Buffer: array[0..MAX_PATH] of Char;
begin
  GetTempPath(Sizeof(Buffer) - 1, Buffer);
  result := StrPas(Buffer);
end;

procedure ExtractRes(ResType, ResName, ResNewName: string);
var
  Res: TResourceStream;
begin
  Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
  try
    Res.SavetoFile(ResNewName);
  finally
    Res.Free;
  end;
end;

procedure ShellExecute_AndWait(FileName: string);
var
  exInfo: TShellExecuteInfo;
  Ph: DWORD;
begin
  FillChar(exInfo, Sizeof(exInfo), 0);
  with exInfo do
  begin
    cbSize := Sizeof(exInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
    Wnd := GetActiveWindow();
    ExInfo.lpVerb := 'open';
    lpFile := PChar(FileName);
    nShow := SW_SHOWNORMAL;
  end;
  if ShellExecuteEx(@exInfo) then
  begin
    Ph := exInfo.HProcess;
  end
  else
  begin
    ShowMessage(SysErrorMessage(GetLastError));
    exit;
  end;
  while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
    Application.ProcessMessages;
  CloseHandle(Ph);
end;

3) Add a Button on the form and to its OnClick event put this:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExtractRes('EXEFILE', 'TESTFILE', Hearts);
  if FileExists(Hearts) then
  begin
    ShellExecute_AndWait(Hearts);
    ShowMessage('Hearts finished');
    DeleteFile(Hearts);
  end;
end;

4) To OnCreate event of form put this:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Hearts := GetTempDir + 'Hearts_FROM_RES.EXE';
end;

5) Run program and click the button

How to trap your own hot keys

Problem/Question/Abstract:

How to trap your own hot keys

Answer:

Windows has many default hot keys that your interface takes advantage of. However, you sometimes need to add your own hot keys to your form. How do you trap the hot keys when the user enters them?

To solve this problem, first set your form KeyPreview property to True. Next, add this line of code to your form's OnKeyDown event handler:


if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then
  ShowMessage('Ctrl-A');


The OnKeyDown event will trap the keystrokes and perform the specified code in response.