Impersonating a User on Windows NT is a three step process

Problem/Question/Abstract:

How do I simulate the unix SU command under windows NT. In other words I want to run an app under a different user...

Answer:

This code was not written by me.
The original copyright information is still intact.

{*
SU.DPR for Delphi32 Pascal
by Fred - APIKing - de Jong, Heerlen, Netherlands 1997
    home: frejon@worldonline.nl, office: fjng@cbs.nl

su.cpp
   UNIX-like Substitute User for Windows NT

Usage:
   su [NewDomain\][NewUser] [command-line]
   where:
     NewDomain\ is desired domain logon (\\ is ok also)
     NewUser is the name of the user to be impersonated. Default is Administrator.
     command-line is the command to be executed, with parameters. Default is CMD (Console)

Authors:
   David Wihl (wihl@shore.net)
   Steffen Krause (skrause@informatik.hu-berlin.de)

Revision History:
xx-JUL-1995.
       - Removed restriction on command line (User can now specify anything)
       - Added NewDomain logon on command line
       - Added Unicode support but found bug in LogonUserW
03-JUL-1995. Initial public release

Design:
   Impersonating a User on Windows NT is a three step process:
   1-  Logon the User to create a Security identifier
   2-  Enabling access to the Windows Station so the newly logged on NewUser
     can interact. This is necessary even if the Administrator is logging on.
   3-  Creating a process using the Security identifier

   Different privileges are required for steps (1) and (3). Logging on a User
   (LogonUser()) requires the SeTcbPrivilege. Creating a process as another User
   CreateProcessAsUser()) requires SeAssignPrimary and SeIncreaseQuota privileges.
   To grant these privileges, see the Installation Section.

   These two Security API calls were only stablized in NT 3.51, build 1057. SU will
   not work with earlier versions.

   In NT, there is no direct equivalent of UNIX's rwsr-xr-x file permission.

Restrictions and Limitations:
   - There is no logging of failed or successful usage. A future may incorporate
     writing to the Event Log.

Installation:
   The easiest way to selectively grant the three privileges required to use this
   program is:

   1-  Start the User Manager (MUSRMGR)
   2-  Create a new group (e.g. "SU Users")
   3-  Add the three privileges to the group (via Policies\User Rights):
       "Act as part of the operating system"  - SeTcbPrivilege
       "Increase quotas"                      - SeIncreaseQuota
       "Replace a process level token"        - SeAssignPrimaryToken

     NOTE: The three privileges will only be visible if you check
     "Show Advanced User Rights" in the dialog box.
   4-  Add the desired users to the new group (via User\Properties\Group)

   This program was compiled under Visual C++ 2.1 with the June '95 SDK

For more information about Porting from UNIX to NT check the FAQ:
http://www.shore.net/~wihl/unix2nt.html

*}

program su;
{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils { already has SysErrorMessage function };

//{$R VersInfo.RES}

//
// CUSTOMIZATION OPTIONS - put 'em here
const
  DEFAULT_USER: string = 'Administrator';
    // if we don't specify a username, who are we?
  DEFAULT_CMD: string = 'cmd'; // if we don't specify a command, what do we do?
{$DEFINE VERBOSE} // quiet ?la UNIX, or chatty?
  //
  // END CUSTOMIZATION OPTIONS
  //
const
  SECURITY_DESCRIPTOR_REVISION = 1; // from winnt.h, missing in windows.pas
  ////////////////////////////////////////////////////////////////////////
  //                                                                    //
  //               NT Defined Privileges                                //
  //                                                                    //
  ////////////////////////////////////////////////////////////////////////
  SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
  SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
  SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
  SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
  SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
  SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
  SE_TCB_NAME = 'SeTcbPrivilege';
  SE_SECURITY_NAME = 'SeSecurityPrivilege';
  SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
  SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
  SE_system_PROFILE_NAME = 'SesystemProfilePrivilege';
  SE_systemTIME_NAME = 'SesystemtimePrivilege';
  SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
  SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
  SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
  SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
  SE_BACKUP_NAME = 'SeBackupPrivilege';
  SE_RESTORE_NAME = 'SeRestorePrivilege';
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  SE_AUDIT_NAME = 'SeAuditPrivilege';
  SE_system_ENVIRONMENT_NAME = 'SesystemEnvironmentPrivilege';
  SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
  SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';

  { ------------------------------------------------- }

  { support standard Error output, besides standard Output/Input }
var
  Error: TextFile;

procedure InitErrorOutput;
begin
  AssignFile(Error, EmptyStr);
  Rewrite(Error);
  TTextRec(Error).Handle := GetStdHandle(STD_ERROR_HANDLE);
end;

var
  _TokenizeStr: PChar = nil;
  _TokenizeLast: PChar = nil;

function Tokenize(const SourceText: string; const Delimiters: string): string;
{ this is my Delphi version of C's strtok():
    1st call: SourceText is not empty, next calls: SourceText is EmptyStr;
set of delimiters can change while tokenizing;
implicit string memory allocation is hidden for the outside:
    Tokenize only parses one SourceText at a time. }
var
  R, S: PChar;
begin
  if length(SourceText) = 0 then
    R := _TokenizeLast
  else
  begin { cleanup and (re)initialize }
    _TokenizeLast := nil;
    StrDispose(_TokenizeStr);
    _TokenizeStr := StrNew(PChar(SourceText));
    R := _TokenizeStr;
  end;
  if R <> nil then
  begin
    S := R; { find next delim }
    while (S^ <> chr(0)) and (StrScan(PChar(Delimiters), S^) = nil) do
      inc(S);
    if S^ <> chr(0) then
    begin
      S^ := chr(0); { got delim, truncate R result }
      inc(S); { skip over delims to set _TokenizeLast }
      while (S^ <> chr(0)) and (StrScan(PChar(Delimiters), S^) <> nil) do
        inc(S);
      if S^ <> chr(0) then
        _TokenizeLast := S;
    end;
    Result := string(R);
    if S^ = chr(0) then
    begin { cleanup early }
      _TokenizeLast := nil;
      StrDispose(_TokenizeStr);
      _TokenizeStr := nil;
    end
  end
  else
    Result := EmptyStr
end;

{ -------------------------------------------------------------- }
const
  DEFWINSTATION: string = 'WinSta0';
  DEFDESKTOP: string = 'Default';
  WHITESPACE: string = ' ' {SPACE} + chr(9) {TAB} + chr(10) {LF};
  DOMUSERSEP: string = '\';

procedure ErrorHandler(const errmsg: string);
var
  err: dword;
begin
  err := GetLastError;
  writeln(Error, 'Error: ', errmsg, '.');
  write(Error, SysErrorMessage(err));
end;

function SetUserObjectAllAccess(hUserObject: THANDLE): boolean;
var
  pSD: PSecurity_Descriptor;
  si: Security_Information; { dword }
begin
  (* Initialize a security descriptor. *)
  pSD := PSecurity_Descriptor(
    LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
  if pSD = nil then
  begin
    ErrorHandler('Can''t Allocate Local Memory');
    Result := FALSE;
    exit;
  end;
  if not InitializeSecurityDescriptor(pSD, SECURITY_DESCRIPTOR_REVISION) then
  begin
    ErrorHandler('Can''t Initialize Security Descriptor');
    LocalFree(HLOCAL(pSD));
    Result := FALSE;
    exit;
  end;

{* Add a NULL disc. ACL to the security descriptor. *}
  if not SetSecurityDescriptorDacl(pSD,
    TRUE, // specifying a disc. ACL
    PACL(nil),
    FALSE) then // not a default disc. ACL
  begin
    ErrorHandler('Can''t Set Security Descriptor DACL');
    LocalFree(HLOCAL(pSD));
    Result := FALSE;
    exit;
  end;

{* Add the security descriptor to the userobject (like a window or a DDE
   conversation), NOT to a kernelobject (like a process, thread or event). *}
  si := DACL_SECURITY_INformATION;
  Result := SetUserObjectSecurity(hUserObject, si, pSD);

  LocalFree(HLOCAL(pSD));
  if not Result then
    ErrorHandler('Can''t Set NewUser Object Security')
end;

function GetUserObjectName(hUserObject: THandle; var Name: string): boolean;
var
  dw: DWord;
begin
  Name := EmptyStr;
  GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Name), 0, dw);
  SetLength(Name, dw + 1);
  Result := GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Name), dw, dw);
  if Result then
    SetLength(Name, dw - 1)
  else
    Name := EmptyStr;
end;

function GetPrivilegeDisplayName(const PrivilegeName: string): string;
{ PrivilegeName is of string type 'SE_'* }
var
  dw, li: DWord;
begin
  Result := EmptyStr;
  dw := 0;
  li := 0; { li:= dword(MAKELANGID(LANG_DEFAULT, LANG_USER)); }
  if not LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), dw, li)
    then
    dw := 256;
  SetLength(Result, dw + 1);
  if LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), dw, li) then
    SetLength(Result, StrLen(PChar(Result)))
  else
    Result := EmptyStr;
end;

function GetAccountInfo(var CurUser, CurDomain: string): boolean;
var
  dw, dw2: DWord;
  pSD: PSecurity_Descriptor;
  snu: Sid_Name_Use;
begin
  Result := False;
  dw := 255;
  Setlength(CurUser, dw + 1);
  if GetUserName(PChar(CurUser), dw) then
  begin
    SetLength(CurUser, dw - 1);
    dw2 := 256;
    SetLength(CurDomain, dw2);
    snu := SidTypeUser;
    pSD := nil;
    dw := 0; { get needed length for SID }
    LookUpAccountName(nil {LocalMachine}, PChar(CurUser),
      pSD, dw, PChar(CurDomain), dw2, snu);
    if dw <> 0 then
    begin
      pSD := PSecurity_Descriptor(LocalAlloc(LPTR, dw));
      if pSD <> nil then
      begin
        if LookUpAccountName(nil, PChar(CurUser), { get the real thing }
          pSD, dw, PChar(CurDomain), dw2, snu) then
        begin
          SetLength(CurDomain, dw2);
          Result := True;
        end
        else
          CurDomain := EmptyStr;
        LocalFree(HLOCAL(pSD));
      end;
    end;
  end
  else
    CurUser := EmptyStr;
end;

function GetMachineName: string;
var
  dw: DWord;
begin
  dw := MAX_COMPUTERNAME_LENGTH + 1;
  SetLength(Result, MAX_COMPUTERNAME_LENGTH + 1);
  if GetComputerName(PChar(Result), dw) then
    SetLength(Result, dw)
  else
    Result := EmptyStr;
end;

{ ---------------------------------------------------------- }
var
  CurUser, // Current User
  CurDomain, // Current Domain
  pwstr, // password string
  consoleTitle, // Title if new console only
  NewDomUser, // NewDomain\NewUser combination
  CommandLine, // command line we pass to the new process
  NewDomain, // NewDomain to log onto
  NewUser: string; // NewUser to log onto
  startUpInfo: TStartupInfo;
  procInfo: TProcessInformation; // child process info, from CreateProcessAsUser
  hDesktop: HDESK;
  hWindowStation: HWINSTA;
  hUserToken, hConsIn: THANDLE;
  OldConsInMode, NewConsInMode: DWORD;
  NTversion: TOSVersionInfo;
  S, DeskTopName, WinStaName: string;
  RC: integer;

begin { program }
  InitErrorOutput; // Attach outputfile Error to STDERR

  // Make sure we are using the minimum OS version.
  NTversion.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
  if not GetVersionEx(NTversion) then
  begin
    ErrorHandler('Unable to get OS version');
    halt(1);
  end;
  if NTversion.dwPlatformId <> VER_PLATform_WIN32_NT then
  begin
    writeln(Error, 'SU will run only on Windows NT.');
    halt(1);
  end;
  if NTversion.dwBuildNumber < 1057 then // Commercial 3.51 release
  begin
    writeln(Error, 'SU requires at minimum NT version 3.51 build 1057.');
    halt(1);
  end;

  //{$IFDEF DEBUG}
  writeln('SU: NT Version ', NTversion.dwMajorVersion, '.',
    NTversion.dwMinorVersion, ', build ', NTversion.dwBuildNumber);
  // {$ENDIF}

  GetAccountInfo(CurUser, CurDomain);
  writeln('You are ', CurDomain, '\', CurUser);

  // Process the command line parameters
  Tokenize(string(CmdLine), WHITESPACE);
  NewDomUser := Tokenize(EmptyStr, WHITESPACE);
  if length(NewDomUser) = 0 then
  begin
    NewDomUser := DEFAULT_USER;
    CommandLine := DEFAULT_CMD;
  end
  else
  begin
    CommandLine := Tokenize(EmptyStr, EmptyStr);
    if length(CommandLine) = 0 then
      CommandLine := DEFAULT_CMD;
  end;
  if Pos(DOMUSERSEP, NewDomUser) > 0 then
  begin
    NewDomain := Tokenize(NewDomUser, DOMUSERSEP);
    NewUser := Tokenize(EmptyStr, DOMUSERSEP);
    if length(NewUser) = 0 then
      NewUser := DEFAULT_USER;
  end
  else
  begin
    NewDomain := EmptyStr;
    NewUser := NewDomUser;
  end;
  if (length(NewDomain) = 0) and
    ((NewUser = '-?') or (NewUser = '/?') or (NewUser = '?')) then
  begin
    writeln;
    writeln('Runs Windows NT commands under another user''s account.');
    writeln;
    writeln('SU [newdomain\][newuser] [command-line]');
    writeln;
    writeln('  [newdomain\]   Specifies desired domain logon (\\ is ok also).');
    writeln('  [newuser]      Specifies the name of the user to be impersonated.');
    writeln('                   The default is Administrator.');
    writeln('  [command-line] Specifies the command to be executed, with parameters.');
    writeln('                   The default is CMD (a new NT Console).');
    writeln;
    writeln('Requires three extended NT privileges:');
    writeln;
    writeln('  ', GetPrivilegeDisplayName(SE_TCB_NAME), ',');
    writeln('  ', GetPrivilegeDisplayName(SE_ASSIGNPRIMARYTOKEN_NAME), ' and');
    writeln('  ', GetPrivilegeDisplayName(SE_INCREASE_QUOTA_NAME), '.');
    writeln;
    writeln('These can be granted as User Rights with NT User Manager.');
    halt(0);
  end;

  // Turn off console mode echo, since we don't want clear-screen passwords
  system.Reset(Input); {GetStdHandle(STD_INPUT_HANDLE)}
  hConsIn := TTextRec(Input).Handle;

  //if hConsIn = INVALID_HANDLE_values then
  //begin
  //  ErrorHandler ('Can''t get handle of STDIN'); halt(1);
  //end;

  if not GetConsoleMode(hConsIn, OldConsInMode) then
  begin
    ErrorHandler('Can''t get current Console Mode');
    halt(1);
  end;
  NewConsInMode := OldConsInMode and (not ENABLE_ECHO_INPUT);
  if not SetConsoleMode(hConsIn, NewConsInMode) then
  begin
    ErrorHandler('Unable to turn off Echo');
    halt(1);
  end;

  // Ask for the password
{$IFDEF VERBOSE}
  if length(NewDomain) = 0 then
    S := CurDomain
  else
    S := NewDomain;
  writeln('Logging onto ', S, ' domain as ', NewUser, '.');
{$ENDIF}
  write('Enter password: ');
  readln(pwstr);
  // When echo is off and NewUser hits , CR-LF is not echoed, so do it for him
  writeln;
  if not SetConsoleMode(hConsIn, OldConsInMode) then
  begin
    ErrorHandler('Unable to reset previous console mode');
    halt(1);
  end;
  CloseHandle(hConsIn);

  // Do the Logon
  if not LogonUser(PChar(NewUser), PChar(NewDomain), PChar(pwstr),
    LOGON32_LOGON_INTERACTIVE,
    LOGON32_PROVIDER_DEFAULT, hUserToken) then
  begin
    case GetLastError of
      ERROR_PRIVILEGE_NOT_HELD:
        begin
          writeln(Error,
            'Error: you do not have the following extended User Right:');
          writeln(Error, GetPrivilegeDisplayName(SE_TCB_NAME), '.');
        end;
      ERROR_LOGON_FAILURE:
        ErrorHandler('LogonUser failed.');
      ERROR_ACCESS_DENIED:
        ErrorHandler('Access is denied');
    else
      ErrorHandler('Unable to logon');
    end;
    halt(2);
  end;

  // give the NewUser access to the current WindowStation and Desktop
  hWindowStation := GetProcessWindowStation;
  if not GetUserObjectName(hWindowStation, WinStaName) then
    WinStaName := DEFWINSTATION;
  if not SetUserObjectAllAccess(hWindowStation) then
  begin
    write(Error, 'Can''t set WindowStation ', WinStaName, ' security.');
    CloseHandle(hUserToken);
    halt(3);
  end;
  hDesktop := GetThreadDesktop(GetCurrentThreadId);
  if not GetUserObjectName(hDesktop, DeskTopName) then
    DeskTopName := DEFDESKTOP;
  if not SetUserObjectAllAccess(hDesktop) then
  begin
    write(Error, 'Can''t set Desktop ', DeskTopName, ' security.');
    CloseHandle(hUserToken);
    halt(3);
  end;

  // Set the STARTUPINFO for the new process
  if length(NewDomain) <> 0 then
    NewDomain := NewDomain + '\';
  consoleTitle := 'SU: ' + NewDomain + NewUser;
  FillChar(startUpInfo, sizeof(startUpInfo), 0);
  with startUpInfo do
  begin
    cb := sizeof(startUpInfo);
    lpTitle := PChar(consoleTitle);
    S := WinStaName + '\' + DeskTopName;
    lpDesktop := PChar(S);
  end;

  // Create the child process
  if not CreateProcessAsUser(hUserToken,
    nil, PChar(CommandLine), nil, nil, FALSE {no inherit handles},
    CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP,
    nil, nil, startUpInfo, procInfo) then
  begin
    case GetLastError of
      ERROR_PRIVILEGE_NOT_HELD:
        begin
          writeln(Error, 'Error: missing (one of) following extended User Rights:');
          writeln(Error, GetPrivilegeDisplayName(SE_ASSIGNPRIMARYTOKEN_NAME), ', or');
          writeln(Error, GetPrivilegeDisplayName(SE_INCREASE_QUOTA_NAME), '.');
          ErrorHandler(EmptyStr);
        end;
      ERROR_FILE_NOT_FOUND:
        ErrorHandler('Error: command in ''' + CommandLine + ''' not found.');
    else
      ErrorHandler('Error: CreateProcessAsUser failed.');
    end;
    RC := 4;
  end
  else
    RC := 0;

  CloseHandle(hWindowStation);
  CloseHandle(hDesktop);
  CloseHandle(hUserToken);

  if RC = 0 then
  begin
    CloseHandle(procInfo.hThread);
    CloseHandle(procInfo.hProcess);
  end;

  halt(RC);

end.

How to avoid direct input into a TDBGrid when there is a lookup list available

Problem/Question/Abstract:

In my TDBGrid, some columns have a picklist. Users can enter any value in these columns, not only values from the picklist. Does anybody know a simple way to prevent this? I would like either to suppress direct input and only allow selection of an existing item of the picklist, or check that input is in the picklist.

Answer:

procedure DBGridColExit(Sender: TObject);
var
  S: string;
begin
  with TDBGrid(Sender) do
  begin
    if (SelectedField = myfield) and
      (Columns[SelectedIndex].PickList.IndexOf(SelectedField.AsString) = -1) then
      with SelectedField do
      begin
        S := AsString;
        AsString := '';
        raise ExceptionCreate(S + ' is not a valid thingummy.' +
          #13'Choose a value from the drop-down list.');
      end;
  end;
end;

How to check if a menu selection has been dispatched by the TPopupList

Problem/Question/Abstract:

I am creating a dynamic popup menu, fill it and call Popup to show the menu. After that method returns I am done with the menu, so I free it (see comment of Peter below). The problems is the OnClick events never get called. I found the problem but don't see how to get around it. When the menu is created it is added to the PopupList which has created a hidden window whose responsibility it is to dispatch the wm_Command message sent by all popup menus. The problem is that the wm_Command is happening after the Popup menu method returns and after I have freed the menu and it has been removed from the PopupList.

How do I get around this? I don't see a mechanism to check if the menu selection has been dispatched by the PopupList before freeing the menu item. I guess I could make the Popup menu a field of my class and free it in the OnClick Events but I won't be able to free the menu if no menu item is selected. I don't like this solution since the only place I need the popup is in one method of my class so I want to keep it a local variable.

Answer:

You go badly wrong when you think you're done. When Popup returns you are not done with the menu, you have just shown it and the user can now make a menu selection or close the menu by clicking elsewhere or hittin ESC. Only after that has happended are you truely "done" with the menu, if you destroy the VCl wrapper earlier the windows menu may visually persist but you have destroyed the link between it and your code.

In D5 there is a solution to your problem. Add this unit to your project (no further code is needed) and the active form will get the custom messages declared in the units interface. You could destroy the popup menu instance when you see CM_EXITMENULOOP. This solution does not work in earlier versions of Delphi which did not expose the Popuplist to the outside world. In these versions the only solution would be to install a WH_CALLWNDPROC hook (thread specific) when the menu is popped up and remove it again when it gets the WM_EXITMENULOOP message.

unit ExPopupList;

interface

uses
  Controls;

const
  CM_MENUCLOSED = CM_BASE - 1;
  CM_ENTERMENULOOP = CM_BASE - 2;
  CM_EXITMENULOOP = CM_BASE - 3;

implementation

uses Messages, Forms, Menus;

type
  TExPopupList = class(TPopupList)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

  { TExPopupList }

procedure TExPopupList.WndProc(var Message: TMessage);
  procedure Send(msg: Integer);
  begin
    if Assigned(Screen.Activeform) then
      Screen.ActiveForm.Perform(msg, Message.wparam, Message.lparam);
  end;
begin
  case message.Msg of
    WM_ENTERMENULOOP:
      Send(CM_ENTERMENULOOP);
    WM_EXITMENULOOP:
      Send(CM_EXITMENULOOP);
    WM_MENUSELECT:
      with TWMMenuSelect(Message) do
        if (Menuflag = $FFFF) and (Menu = 0) then
          Send(CM_MENUCLOSED);
  end;
  inherited;
end;

initialization
  PopupList.Free;
  PopupList := TExPopupList.Create;
  {Note: will be freed by Finalization section of Menus unit}
end.

How to use WriteBinaryData

Problem/Question/Abstract:

Can someone explain exactly how to use WriteBinaryData? I've tried several different ways but the output is never what it should be.

Answer:

uses
  Registry

var
  RG: Registry;
  PrinterName: string; {This is just a value}
  Buffer: array[0..1024] of Char; {This is the Binary data}
  J, K: Integer;
  dFiles: array[0..5] of string;
    {The string data that will be converted to Binary Data}
  S, S2: string;
  sChar: Char;

procedure Whatever;
begin
  {Reset buffer}
  for i := 0 to 1024 do
    buffer[i] := #00;
  {Reset S}
  S := '';
  dfiles[0]: 'MyPrint.Drv';
  dfiles[1]: 'MyPrint.DLL';
  dfiles[2]: 'Myunit.DLL';
  dfiles[3]: 'MyPrint.HLP';
  dfiles[4]: 'MyPrnt2.DLL';
  dfiles[5]: 'MyPrnt3.DLL';
  {Copy all items into one string seperated by a NULL ##00}
  for J := 0 to 5 do
  begin
    S := S + dFiles[k] + #00; {Copy strings to 1 string and add a #00}
    K := Length(S); {K function is to store the string length}
  end;
  {Convert String to char array called buffer}
  for J := 1 to K do
  begin
    S2 := Copy(S, J, 1); {Copy 1 char to string S2}
    sChar := S2[1]; {Copy S2 to sChar}
    buffer[J - 1] := sChar; {Copy sChar to buffer}
  end;
  {The char array MUST end with 2 NULLS}
  Buffer[K + 1] := #00;
  Printername := 'MyPrinter';
  rg := TRegistry.create;
  rg.rootkey := hkey_local_machine;
  rg.Openkey('System\CurrentControlSet\Control\Print\Environments\Windows4.0\Drivers\'
    + PrinterName, true);
  rg.writebinarydata('Dependent Files', buffer, K + 1);
  rg.Closekey;
end;

How to get the scrollbar positon in a RichEdit control

Problem/Question/Abstract:

Is it possible to read the actual position of a scrollbar from a richedit-component?

Answer:

Solve 1:
YES, you can get the position of the scroll bar, by several ways. Here is some code that gets the scroll bar position for a RichEdit. I also subclass the RichRdit to get the WM_VSCROLL message and move the Claret to the top line plus one character

private
{ Private declarations }
PRichEdWndProc, POldWndProc: Pointer;

procedure RichEdWndProc(var Msg: TMessage);

procedure TForm1.FormCreate(Sender: TObject);
begin
  {subclass the richedit to get the windows messages}
  PRichEdWndProc := MakeObjectInstance(RichEdWndProc);
  POldWndProc := Pointer(SetWindowLong(RichEdit1.Handle, GWL_WNDPROC,
    Integer(PRichEdWndProc)));
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  {un-sublass it so you app can close}
  if Assigned(PRichEdWndProc) then
  begin
    SetWindowLong(RichEdit1.Handle, GWL_WNDPROC, Integer(POldWndProc));
    FreeObjectInstance(PRichEdWndProc);
  end;
end;

procedure TForm1.RichEdWndProc(var Msg: TMessage);
begin
  Msg.Result := CallWindowProc(POldWndProc, RichEdit1.Handle, Msg.Msg, Msg.WParam,
    Msg.LParam);

  if (Msg.Msg = WM_VSCROLL) and (LOWORD(Msg.wParam) = SB_THUMBTRACK) then
  begin
    {the SB_THUMBTRACK message is only sent when the user moves the scroll
                 bar position}
    Label1.Caption := 'thumb Pos is ' + IntToStr(HIWORD(Msg.Wparam));
    RichEdit1.SelStart := RichEdit1.Perform(EM_LINEINDEX,
      RichEdit1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0), 0) + 1;
  end;

end;

procedure TForm1.but_REditInfoClick(Sender: TObject);
var
  ScrolPos, VisLineOne: Integer;
  ScrollInfo1: TScrollInfo;
begin
  {use some windows messages to get scroll position and other info}
  VisLineOne := RichEdit1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);

  ScrollInfo1.cbSize := SizeOf(TScrollInfo);
  ScrollInfo1.fMask := SIF_RANGE;
  GetScrollInfo(RichEdit1.Handle, SB_VERT, ScrollInfo1);
  ScrolPos := GetScrollPos(RichEdit1.Handle, SB_VERT);
  ShowMessage('ScrolPos is ' + IntToStr(ScrolPos) + ' First Vis Line is ' +
    IntToStr(VisLineOne) + ' Scroll max is ' + IntToStr(ScrollInfo1.nMax));
end;


Solve 2:

The most simple way

function GetHorzScrollBarPosition: Integer;
begin
  // constants: SB_HORZ = 0, SB_VERT = 1,
  // SB_BOTH = 3, SB_THUMBPOSITION = 4
  Result := GetScrollPos(RichEdit1.Handle, SB_HORZ);
  // Result is the number of pixels the RichEdit is scrolled
end;

Make a Word document read-only when opend in a TOleContainer

Problem/Question/Abstract:

How to make a Word document read-only when opend in a TOleContainer

Answer:

You could use the document's Protect method, e.g.:

{ ... }
OleContainer1.DoVerb(ovShow);
OleContainer1.OleObject.Protect(wdAllowOnlyComments, EmptyParam, EmptyParam);
{ ... }

How to write a component resource to a file

Problem/Question/Abstract:

I decided to change the way my application saves its form details by using WriteComponentResFile. Basically, my application allows users to create their own forms at run-time (but really just let them change the contents of a panel). Using WriteComponentResFile('Panel.Dfm', MainPanel); doesn't write the buttons or images held by the panel to the DFM file. All that is saved is the panel info itself.

Answer:

The key is to make the controls the user drops on the panel owned by the panel, not the form. Here is an example project to show the principle. Note that you need to register all classes the user can drop so the streaming system knowns how to create them.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    CloseButton: TButton;
    Panel1: TPanel;
    PopupMenu1: TPopupMenu;
    Button2: TMenuItem;
    Edit1: TMenuItem;
    Label2: TMenuItem;
    SaveButton: TButton;
    RestoreButton: TButton;
    procedure CloseButtonClick(Sender: TObject);
    procedure PopupMenuClick(Sender: TObject);
    procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SaveButtonClick(Sender: TObject);
    procedure RestoreButtonClick(Sender: TObject);
  private
    { Private declarations }
    FPopupPosition: TPoint;
    function Filename: string;
    procedure CustomButtonClick(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CloseButtonClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.PopupMenuClick(Sender: TObject);
var
  ctrl: TControl;
  S: string;
  i: Integer;
begin
  case (Sender as TMenuItem).Tag of
    1:
      begin
        ctrl := TButton.Create(panel1);
        TButton(ctrl).OnClick := CustombuttonClick;
      end;
    2: ctrl := TEdit.Create(Panel1);
    3: ctrl := TLabel.Create(Panel1);
  else
    Exit;
  end;
  ctrl.Top := FPopupPosition.Y;
  ctrl.Left := FPopupPOsition.x;
  ctrl.Parent := panel1;
  S := ctrl.Classname;
  Delete(S, 1, 1);
  i := 1;
  while panel1.FindComponent(S + IntToStr(i)) <> nil do
    Inc(i);
  ctrl.Name := S + IntToStr(i);
end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  p: TPoint;
begin
  if Button <> mbLeft then
    Exit;
  FPopupPosition := Point(X, Y);
  p := (Sender as TPanel).ClientToScreen(FPopupPosition);
  PopupMenu1.Popup(p.x, p.y);
end;

function TForm1.Filename: string;
begin
  result := ExtractFilePath(ParamStr(0)) + Name + '.DAT';
end;

procedure TForm1.SaveButtonClick(Sender: TObject);
var
  fs: TFileStream;
  i: Integer;
begin
  fs := TFileStream.Create(filename, fmCreate);
  try
    fs.WriteComponent(panel1);
  finally
    fs.free
  end;
  for i := panel1.ComponentCount - 1 downto 0 do
    panel1.Components[i].Free;
end;

procedure TForm1.RestoreButtonClick(Sender: TObject);
var
  fs: TFileStream;
  i: Integer;
begin
  fs := TFileStream.Create(filename, fmOpenread or fmShareDenyWrite);
  try
    fs.ReadComponent(panel1);
    { Note: this will restore all properties of the read objects,
                with the  exception of events. Since the event handlers belong to the form,
                not the panel, the reader is unable to resolve the method names to
                method pointers. So we have to reconnect the event here manually. }
    for i := panel1.ComponentCount - 1 downto 0 do
      if panel1.Components[i] is TButton then
        TButton(panel1.Components[i]).OnClick := CustomButtonClick;
  finally
    fs.free
  end;
end;

procedure TForm1.CustomButtonClick(Sender: TObject);
begin
  ShowMessage((Sender as TButton).Name);
end;

initialization
  RegisterClasses([TButton, TEdit, TLabel]);
end.

---------------------------------------------------------------------------------------------
object Form1: TForm1
  Left = 215
    Top = 109
    Width = 556
    Height = 303
    Caption = 'Form1'
    Color = clBtnFace
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -15
    Font.Name = 'Arial'
    Font.Style = []
    OldCreateOrder = False
    Scaled = False
    PixelsPerInch = 120
    TextHeight = 17
    object CloseButton: TButton
    Left = 24
      Top = 28
      Width = 75
      Height = 25
      Caption = 'Close'
      TabOrder = 0
      OnClick = CloseButtonClick
  end
  object Panel1: TPanel
    Left = 112
      Top = 24
      Width = 421
      Height = 237
      Caption = 'Click me!'
      TabOrder = 1
      OnMouseDown = Panel1MouseDown
  end
  object SaveButton: TButton
    Left = 24
      Top = 60
      Width = 75
      Height = 25
      Caption = 'Save'
      TabOrder = 2
      OnClick = SaveButtonClick
  end
  object RestoreButton: TButton
    Left = 24
      Top = 92
      Width = 75
      Height = 25
      Caption = 'Restore'
      TabOrder = 3
      OnClick = RestoreButtonClick
  end
  object PopupMenu1: TPopupMenu
    Left = 112
      Top = 4
      object Button2: TMenuItem
      Tag = 1
        Caption = 'Button'
        OnClick = PopupMenuClick
    end
    object Edit1: TMenuItem
      Tag = 2
        Caption = 'Edit'
        OnClick = PopupMenuClick
    end
    object Label2: TMenuItem
      Tag = 3
        Caption = 'Label'
        OnClick = PopupMenuClick
    end
  end
end
---------------------------------------------------------------------------------------------

Create an item in a TActionMainMenuBar at runtime

Problem/Question/Abstract:

How to create an item in a TActionMainMenuBar at runtime

Answer:

{ ... }
var
iItem: TActionClientItem;
iAction: TAction;
begin
iAction := TAction.Create(myActionManager); {Create the Action for the item}
iItem := myActionManager.ActionBars[0].Items.Add; {Add item to menu with the index 0}
iAction.Caption := 'My Item';
iItem.Action := iAction; {Assign Action to the item}
end;

To create a submenu item, do:

{ ... }
var
iItem: TActionClientItem;
iAction: TAction;
begin
iAction := TAction.Create(myActionManager);
iItem :=
myActionManager.ActionBars[0].Items[MyFirstMenu].Items[MyFirstSubmenu].Items.Add;
iAction.Caption := 'My item in the submenu';
iItem.Action := iAction;
end;

How to mirror and rotate bitmaps

Problem/Question/Abstract:

How to mirror and rotate bitmaps

Answer:

{Turn off Range Checking because of ARRAY[0..0] construct below}

{$R-}

unit Bitmap;

interface

uses
  Windows, Graphics;

procedure MirrorHorizontal(Bitmap: TBitmap);
procedure MirrorVertical(Bitmap: TBitmap);
procedure Rotate90Degrees(Bitmap: TBitmap);
procedure Rotate270Degrees(Bitmap: TBitmap);
procedure Rotate180Degrees(Bitmap: TBitmap);

implementation

uses
  dialogs, Classes, SysUtils;

type
  EBitmapError = class(Exception);
  TRGBArray = array[0..0] of TRGBTriple;
  pRGBArray = ^TRGBArray;

procedure MirrorHorizontal(Bitmap: TBitmap);
var
  i, j, w: Integer;
  RowIn: pRGBArray;
  RowOut: pRGBArray;
begin
  w := bitmap.width * sizeof(TRGBTriple);
  GetMem(rowin, w);
  for j := 0 to Bitmap.Height - 1 do
  begin
    move(Bitmap.Scanline[j]^, rowin^, w);
    rowout := Bitmap.Scanline[j];
    for i := 0 to Bitmap.Width - 1 do
      rowout[i] := rowin[Bitmap.Width - 1 - i];
  end;
  bitmap.Assign(bitmap);
  FreeMem(rowin);
end;

procedure MirrorVertical(Bitmap: TBitmap);
var
  j, w: Integer;
  help: TBitmap;
begin
  help := TBitmap.Create;
  help.Width := Bitmap.Width;
  help.Height := Bitmap.Height;
  help.PixelFormat := Bitmap.PixelFormat;
  w := Bitmap.Width * sizeof(TRGBTriple);
  for j := 0 to Bitmap.Height - 1 do
    move(Bitmap.Scanline[j]^, Help.Scanline[Bitmap.Height - 1 - j]^, w);
  Bitmap.Assign(help);
  help.free;
end;

type
  THelpRGB = packed record
    rgb: TRGBTriple;
    dummy: byte;
  end;

procedure Rotate270Degrees(Bitmap: TBitmap);
var
  aStream: TMemorystream;
  header: TBITMAPINFO;
  dc: hDC;
  P: ^THelpRGB;
  x, y, b, h: Integer;
  RowOut: pRGBArray;
begin
  aStream := TMemoryStream.Create;
  aStream.SetSize(Bitmap.Height * Bitmap.Width * 4);
  with header.bmiHeader do
  begin
    biSize := SizeOf(TBITMAPINFOHEADER);
    biWidth := Bitmap.Width;
    biHeight := Bitmap.Height;
    biPlanes := 1;
    biBitCount := 32;
    biCompression := 0;
    biSizeimage := aStream.Size;
    biXPelsPerMeter := 1;
    biYPelsPerMeter := 1;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  dc := GetDC(0);
  P := aStream.Memory;
  GetDIBits(dc, Bitmap.Handle, 0, Bitmap.Height, P, header, dib_RGB_Colors);
  ReleaseDC(0, dc);
  b := bitmap.Height; {rotate}
  h := bitmap.Width; {rotate}
  bitmap.Width := b;
  bitmap.height := h;
  for y := 0 to (h - 1) do
  begin
    rowOut := Bitmap.ScanLine[(h - 1) - y];
    P := aStream.Memory; {reset pointer}
    inc(p, y);
    for x := (b - 1) downto 0 do
    begin
      rowout[x] := p^.rgb;
      inc(p, h);
    end;
  end;
  aStream.Free;
end;

procedure Rotate90Degrees(Bitmap: TBitmap);
var
  aStream: TMemorystream;
  header: TBITMAPINFO;
  dc: hDC;
  P: ^THelpRGB;
  x, y, b, h: Integer;
  RowOut: pRGBArray;
begin
  aStream := TMemoryStream.Create;
  aStream.SetSize(Bitmap.Height * Bitmap.Width * 4);
  with header.bmiHeader do
  begin
    biSize := SizeOf(TBITMAPINFOHEADER);
    biWidth := Bitmap.Width;
    biHeight := Bitmap.Height;
    biPlanes := 1;
    biBitCount := 32;
    biCompression := 0;
    biSizeimage := aStream.Size;
    biXPelsPerMeter := 1;
    biYPelsPerMeter := 1;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  dc := GetDC(0);
  P := aStream.Memory;
  GetDIBits(dc, Bitmap.Handle, 0, Bitmap.Height, P, header, dib_RGB_Colors);
  ReleaseDC(0, dc);
  b := bitmap.Height; {rotate}
  h := bitmap.Width; {rotate}
  bitmap.Width := b;
  bitmap.height := h;
  for y := 0 to (h - 1) do
  begin
    rowOut := Bitmap.ScanLine[y];
    P := aStream.Memory; {reset pointer}
    inc(p, y);
    for x := 0 to (b - 1) do
    begin
      rowout[x] := p^.rgb;
      inc(p, h);
    end;
  end;
  aStream.Free;
end;

procedure Rotate180Degrees(Bitmap: TBitmap);
var
  i, j: Integer;
  rowIn: pRGBArray;
  rowOut: pRGBArray;
  help: TBitmap;
begin
  help := TBitmap.Create;
  help.Width := Bitmap.Width;
  help.Height := Bitmap.Height;
  help.PixelFormat := Bitmap.PixelFormat;
  < {only pf24bit for now}
  for j := 0 to Bitmap.Height - 1 do
  begin
    rowIn := Bitmap.ScanLine[j];
    rowOut := help.ScanLine[Bitmap.Height - j - 1];
    for i := 0 to Bitmap.Width - 1 do
      rowOut[Bitmap.Width - i - 1] := rowIn[i]
  end;
  bitmap.assign(help);
  help.free;
end;

end.

Check if MS SQL Server is reachable

Problem/Question/Abstract:

Can I find programmatically if certain MS SQL Server is reachable on net?

Answer:

Here is function, performing check if MS SQL Server is reachable on net against given server name (usually host on that MS SQL Server is installed), user name and password

function CheckMSSQLServer(fServerName, fUserName, fPsw: string): Bool;
var
  wDb: TDatabase;
begin // Check if MS SQL Server is reachable
  // Important! BDE Must be installed
  Result := False;
  wDb := TDatabase.Create(nil);

  with wDb do
  begin
    DatabaseName := 'wDbDatabaseName'; // arbitrary name, must be unique
    // in current Session
    Params.Values['SERVER Name'] := fServerName;
    Params.Values['USER Name'] := fUserName;
    Params.Values['PASSWORD'] := fPsw;
    LoginPrompt := False;
  end;

  try
    wDb.DriverName := 'MSSQL';
    try
      wDb.Connected := True;
      wDb.Connected := False;
    except
      ShowMessage('Server is not reachable');
    end;
    Result := True;
  finally
    wDb.Free;
  end;
end;

How to get and set the DPI in a TBitmap

Problem/Question/Abstract:

How to get and set the DPI in a TBitmap

Answer:

I got tired of GetDIBits returning zero's in the BitmapInfoHeader XPelsPerMeter and YPelsPerMeter. The following unit allow you to get/set the dpi to a bitmap file or bitmap image.

As has been discussed previously, a bitmap doesn't really have a dpi as far as the screen is concerned, just a height and width. But the original dpi is indispensable for determining the original size or the scale of the original scan, as is necessary in a program I am working on right now.

The XPelsPerMeter and YPelsPerMeter are stored in 2 bytes each at an offset of 38(26h) and 42(2Ah), I don't know or care which one is at which address. These 2 values are virtually always the same. So in both of my 'Get' functions I just get the one at offset 38. When I set the dpi though, I write both. You can change this accordingly if you like.

There are 39.370079 In/Meter, so, dpi * 39.370079 = dots/meter (PelsPerMeter).


unit MyGraphic;

interface

uses
  SysUtils, Classes, Graphics, Dialogs;

function GetBMPFileDPI(FileName: string): LongInt;
procedure SetBMPFileDPI(FileName: string; DPI: Integer);
function GetBmpDPI(Bitmap: TBitmap): LongInt;
procedure SetBmpDPI(Bitmap: TBitmap; DPI: Integer);

implementation

function GetBMPFileDPI(FileName: string): LongInt;
var
  Stream: TFileStream;
  Data: Word;
  A: Double;
begin
  try
    Result := 0;
    Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
    Stream.Position := 38;
    if Stream.Read(Data, 2) = 2 then
    begin
      A := Data;
      Result := Round(A / 39.370079);
    end;
  finally
    Stream.Free;
  end;
end;

procedure SetBMPFileDPI(FileName: string; DPI: Integer);
var
  Stream: TFileStream;
  Data: Word;
begin
  try
    Stream := TFileStream.Create(FileName, fmOpenWrite or fmShareExclusive);
    Data := Round(DPI * 39.370079);
    Stream.Position := 38;
    if Stream.Write(Data, 2) = 2 then
    begin
      Stream.Position := 42;
    end
    else
      {Error writing to Stream...}
      ShowMessage('Error writing to Stream. Data not written.');
  finally
    Stream.Free;
  end;
end;

function GetBmpDPI(Bitmap: TBitmap): LongInt;
var
  Stream: TMemoryStream;
  Data: Word;
  A: Double;
begin
  try
    Result := 0;
    Stream := TMemoryStream.Create;
    Bitmap.SaveToStream(Stream);
    Stream.Position := 38;
    if Stream.Read(Data, 2) = 2 then
    begin
      A := Data;
      Result := Round(A / 39.370079);
    end;
  finally
    Stream.Free;
  end;
end;

procedure SetBmpDPI(Bitmap: TBitmap; DPI: Integer);
var
  Stream: TMemoryStream;
  Data: Word;
begin
  try
    Stream := TMemoryStream.Create;
    Bitmap.SaveToStream(Stream);
    Data := Round(DPI * 39.370079);
    Stream.Position := 38;
    if Stream.Write(Data, 2) = 2 then
    begin
      Stream.Position := 42;
      if Stream.Write(Data, 2) = 2 then
      begin
        Stream.Position := 0;
        Bitmap.LoadFromStream(Stream);
      end
      else
        {Error writing to Stream...}
        ShowMessage('Error writing to Stream. Data not written.');
    end
    else
      {Error writing to Stream...}
      ShowMessage('Error writing to Stream. Data not written.');
  finally
    Stream.Free;
  end;
end;

end.

How to load a frame from a DLL

Problem/Question/Abstract:

I want load a TFrame from a DLL in the main program. I always get the error "No parent window", although I already have the main form's handle.

Answer:

library DLLFrame;

uses
  SysUtils, Classes, Controls, Forms, Windows,
  DllFrameFrame in 'DllFrameFrame.pas' {Frame1: TFrame};

procedure AddFrame(ApplicationHandle, ParentHandle: THandle); stdcall;
var
  Frame1: TFrame1;
  AppHandle: THandle;
begin
  AppHandle := Application.Handle;
  Application.Handle := ApplicationHandle;
  Frame1 := TFrame1.Create(Application);
  Frame1.ParentWindow := ParentHandle;
  SetParent(Frame1.Handle, ParentHandle);
  Frame1.Align := alClient;
  Frame1.Visible := True;
  Application.Handle := AppHandle;
end;

exports
  AddFrame;

begin
end.

unit DllFrameFrame;

interface

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

type
  TFrame1 = class(TFrame)
    Label1: TLabel;
    Label2: TLabel;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

implementation

{$R *.dfm}

end.

program LoadDLLFrame;

uses
  Forms, LoadDLLFrameMn in 'LoadDLLFrameMn.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit LoadDLLFrameMn;

interface

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

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

var
  Form1: TForm1;

procedure AddFrame(ApplicationHandle, ParentHandle: THandle); stdcall;

implementation

{$R *.dfm}

procedure AddFrame(ApplicationHandle, ParentHandle: THandle); stdcall;
  external 'DLLFrame.dll';

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddFrame(Application.Handle, Panel1.Handle);
end;

end.

Error message "bordbk50.dll not registered"

Problem/Question/Abstract:

When starting a debug session under Delphi 5.0, many people receive the error message stating "bordbk50.dll not registered". Borland CBuilder 5 has similar issues with library bordbk51.dll.

Answer:

What is the problem?

&#8220;Bordbk&#8221; is the debugger kernel (&#8220;BORland DeBug Kernel&#8221;).
There is a bug in the installation program which fails to register this DLL. Some people believe that this occurs only on systems where a certain registry editor command-line tool is not on the search path &#8211; this is not true since I experienced the problem also.
It looks like Borland made a mistake both in their Delphi 5.0 and CBuilder 5 installation scripts.

Solution

The good news is that there is a simple solution. Check on your hard disk for the missing file. The default location is

C:\Program Files\Common Files\Borland Shared\Debugger\bordbk50.dll

Then open a DOS shell, go into that directory and type in this command:

Regsvr32 bordbk50.dll

Regsvr32 is the aforementioned command-line editing tool. It will register the DLL. If regsv32 is not in you path then you will need to prefix it with the full path.

A Delphi implementation of the Shellsort algorithm

Problem/Question/Abstract:

A Delphi implementation of the Shellsort algorithm

Answer:

function FirstLow(var A, B: Str64): Boolean;
begin
  if A < B then
    FirstLow := True
  else
    FirstLow := false;
end;

procedure BinArraySort(Start, Finish: Integer; var Data: PosAry);
var
  StarterKey: Str64;
  Temp: PositionRec; {see remark below}
  Left: Integer;
  Right: Integer;
begin
  Left := Start;
  Right := Finish;
  StarterKey := Data[(Start + Finish) div 2].PBStr;
  repeat
    while FirstLow(Data[Left].PBStr, StarterKey) do
      Left := Left + 1;
    while FirstLow(StarterKey, Data[Right].PBStr) do
      Right := Right - 1;
    if Left <= Right then
    begin
      Temp := Data[Left];
      Data[Left] := Data[Right];
      Data[Right] := Temp;
      Left := Left + 1;
      Right := Right - 1;
    end;
  until
    Right <= Left;
  if Start < Right then
    BinArraySort(Start, Right, Data);
  if Left < Finish then
    BinArraySort(Left, Finish, Data);
end;

Remark:

PositionRec = record
  PBStr: Str64; {key}
  {additional fields}
end;

PosAry = array[1..??] of PositionRec;
PosAryPtr = ^PosAry

is better than just the array itself. Then:

procedure BinArraySort(Start, Finish: Integer; Data: PosAryPtr);

The caller:

var
  PA: PosAryPtr;
begin
  BinArraySort(1, BItems, PA);

How to stop an application and make it wait until the BDE is installed

Problem/Question/Abstract:

I have a CD-ROM catalog Paradox application. When it is run, it checks if the BDE is installed. If it raises an exception, I do:

ShellExecute(handle, 'open', PChar(ExtractFilePath(Application.ExeName) +
  'BDESetup\Setup.exe), '', nil , SW_SW_SHOWMINNOACTIVE);

My problem is, that the application continues to run before the BDE is installed.

Answer:

The following unit contains two functions that might solve your problem.

The two functions defined in the unit below provide two alternative ways to allow an application to call another application and wait for it to exit before continuing. The called application can be a Win32 app, a Win16 app, or a DOS app. To call a batch file or an internal command.com or cmd.exe command, use something like: 'command.com' or 'cmd.exe' as the app, and '/c dir' as the parameter.

If you want the user to see the app's window, then pass SW_SHOW as the Visibility parameter. If you want to hide it, pass SW_HIDE (defined in Windows.pas).

If the called application cannot be run, then the function returns false, and you can use GetLastError to get an error code, and use SysErrorMessage to turn that into a text error message, if necessary.

If the called application runs, then the function returns true. If the called application runs, but signals an abnormal termination by setting its Exit Code to a non-zero value (rare among Windows applications) but common among DOS utilities), then this Exit Code can be seen in the final var parameter ResultingExitCode.

The wait loop includes a Windows message loop which explicitly looks out for a wm_Quit message to allow the calling application to be closed even if the called application hangs.

unit Exec;

{
Author: Bill Sparrow (bsparrow@cix.co.uk)
Revision history in reverse chronological order:-
13/10/1999  WFS  Original version, tested only in Delphi 3 on NT4 SP3.

Acknowledgements: the code borrows heaviliy from two contributions
posted on the CIX Conferencing system, one of which in turn borrows
from a Compuserve posting:

  magsys@cix.co.uk cix:borland/3delphi32:3488 29/07/1998.
  Francis PARLANT CIS : 100113,3015.
  jatkins@cix.co.uk cix:borland/6delphi:3540 01/11/1998
}

interface

uses Windows;

function ShellExecAndWait(App, Params: string; Visibility: Integer;
  var ResultingExitCode: DWord): Boolean;

function CreateProcAndWait(App, Params: string; Visibility: Word;
  var ResultingExitCode: DWord): Boolean;

implementation

uses
  shellAPI, {for ShellExecuteEx, TShellExecuteInfo, etc.}
  Messages; {for WM_QUIT}

{
Based on a version from jatkins@cix.co.uk cix: borland / 6 delphi: 3540
01 / 11 / 1998
}

{
One advantage of ShellExecuteEx is that it can find the path to the executable without you having to specify it in full, so long as the app has set a registry key under the appropriate App Paths branch.

Another is that instead of passing an application name plus a document filename as a parameter, you can just pass the document name. So long as the document file type has an association, Windows will find the appropriate application to open the document.

ShellExecuteEx is presumably what gets called when you double click a file in Windows Explorer to open it.

Without SEE_MASK_FLAG_NO_UI, if ShellExecuteEx encounters an error, it will display an error dialog to the user before returning False. Furthermore, the text of the error dialog may be an inappropriate level for the user. For instance, if you try to open a document for which there is no association, the error dialog tells the user to set up an association. Turning off the UI allows us to handle the error ourselves and put up an error dialog if appropriate.
}

function ShellExecAndWait(App, Params: string; Visibility: Integer;
  var ResultingExitCode: DWord): Boolean;
var
  Msg: TMsg;
  E: TShellExecuteInfo;
begin
  FillChar(E, SizeOf(E), 0); {Superfulous, but what the heck!}
  E.cbSize := sizeof(E);
  E.fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI;
  E.wnd := 0; {Still not sure about leaving this at zero}
  E.lpVerb := nil; {Defaults to 'open'}
  E.lpFile := PChar(App); {Application or document to open}
  E.lpParameters := PChar(Params); {Optional Command line parameter to pass}
  E.lpDirectory := nil; {Defaults to current directory}
  E.nShow := Visibility; {E.g. SW_SHOW or SW_HIDE}
  if ShellExecuteEx(@E) then
  begin
    repeat
      while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
      begin
        if Msg.Message = wm_Quit then
          Halt(Msg.WParam);
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    until
      WaitForSingleObject(E.hProcess, 50) <> WAIT_TIMEOUT;
    GetExitCodeProcess(E.hProcess, ResultingExitCode);
    CloseHandle(E.hProcess); {Prevent leakage}
    Result := True; {ShellExecuteEx succeeded}
  end
  else
  begin
    ResultingExitCode := 1; {Just so that it is not left undefined}
    Result := False; {ShellExecuteEx failed}
  end;
end;

{From the Win32 help for CreateProcess...

"The created process remains in the system until all threads within the process have
  terminated and all handles to the process and any of its threads have been closed
  through calls to CloseHandle.The handles for both the process and the main
        thread must be closed through calls to CloseHandle.If these handles are not needed,
        it is best to close them immediately after the process is created."

Testing this under NT4 shows a memory leak of 12 K if you don't close the handles.
}

{Based on a version from magsys@cix.co.uk cix:borland/3delphi32:3488
29/07/1998.}

function CreateProcAndWait(App, Params: string; Visibility: Word;
  var ResultingExitCode: DWord): Boolean;
var
  Msg: TMsg;
  SI: TStartupInfo;
  PI: TProcessInformation;
  CommandLine: string;
begin
  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  SI.dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  SI.wShowWindow := Visibility; {E.g. SW_SHOW or SW_HIDE}

  {The first whitespace-delimited 'parameter' in the lpCommandLine needs to be the
  app's path and file name if any following 'real' parameters are to be correctly
  seen by the called application.
  Setting lpApplicationName is optional so long as we comply with the above. If
  we did also set lpApplicationName, however, we would have to ensure that the copy in
  lpCommandLine was in quotes in case it contains a space. If we leave
        lpApplicationName as nil, Windows takes care of this problem for us. Also, if the
   called app is 16 bit, we have to do it this way! On second thoughts, relying on
   Windows to do the quoting would leave us
  open to an ambiguity, so do it explicitly.}

  {If the app's filename contains a space, and is not already quoted, then quote it...}
  if (Pos(' ', App) <> 0) and (Pos('"', App) = 0) then
    CommandLine := '"' + App + '"'
  else
    CommandLine := App;
  {Join the App and the Params into one string with a space between them...}
  if (App <> '') and (Params <> '') then
    CommandLine := CommandLine + ' ';
  CommandLine := CommandLine + Params;
  if CreateProcess(nil, PChar(CommandLine), nil, nil, False, 0, nil, nil, SI, PI) then
  begin
    repeat
      while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
      begin
        if Msg.Message = wm_Quit then
          Halt(Msg.WParam);
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    until
      WaitForSingleObject(PI.hProcess, 50) <> WAIT_TIMEOUT;
    GetExitCodeProcess(PI.hProcess, ResultingExitCode);
    CloseHandle(PI.hThread); {Prevent leakage}
    CloseHandle(PI.hProcess); {Prevent leakage}
    Result := True; {CreateProcess succeeded}
  end
  else
  begin
    ResultingExitCode := 1; {Just so that it is not left undefined}
    Result := False; {CreateProcess failed}
  end;
end;

end.

How to put an image (e.g sort arrow) on a listview column header

Problem/Question/Abstract:

When sorting TListViews it is good practise to show which column is sorted and in which direction.

Answer:

Add this to your form:

uses commctrl;

procedure TForm1.SetColumnImage(List: TListView; Column, Image: Integer; ShowImage:
  Boolean);
var
  Align, hHeader: integer;
  HD: HD_ITEM;
begin
  hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
  with HD do
  begin
    case List.Columns[Column].Alignment of
      taLeftJustify: Align := HDF_LEFT;
      taCenter: Align := HDF_CENTER;
      taRightJustify: Align := HDF_RIGHT;
    else
      Align := HDF_LEFT;
    end;

    mask := HDI_IMAGE or HDI_FORMAT;

    pszText := PChar(List.Columns[Column].Caption);

    if ShowImage then
      fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
    else
      fmt := HDF_STRING or Align;

    iImage := Image

  end;
  SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
end;


Images are taken from the SmallImages list. You should call this function for each column, and set the ShowImage to TRUE for the column you sorted. You can do this in the OnColumnClick() function:


var
  Ascending: boolean;

procedure TForm1.ListViewColumnClick(Sender: TObject; Column: TListColumn);
var
  i: integer;
begin
  // Toggle column Tag
  Column.Tag := 1 - Column.Tag; // 0 -> 1  ;  1 -> 0
  // Determine sort order based on the value of the Tag
  Ascending := Column.Tag = 1;

  // This loop displays the icon in the selected column.
  for i := 0 to ListView.Columns.Count - 1 do
    SetColumnImage(ListView, i, Column.Tag, i = Column.Index);

  // The CustomSort function is not covered in this
  // article but is explained elsewhere in Delphi Knowledge Base
  TListView(Sender).CustomSort(@SortByColumn, Column.Index);
end;

Problem:  Resizing the column header causes a WM_PAINT which will erase the image.
Solution: Override WM_PAINT and call SetColumnImage again from there. I used TApplicationEvents component from delphi 5.
If someone knows a better solution please let me know.

Populate a TStringList with file names from a folder

Problem/Question/Abstract:

I am trying to populate a TStringlist with files matching *.pas;*.dfm;*.dpr etc. from the current folder which is easy enough, but I also want to search sub folder for the same file types and keep their folder structure so that I can copy all the files in one go to another folder and then to CD for extra backups.

Answer:

procedure GetFileList(const Path: string; const Extensions: string; FileList:
  TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
  try
    repeat
      if (SR.Attr and faDirectory) > 0 then
      begin
        if SR.Name[1] <> '.' then
          GetFileList(Path + SR.Name + '\', Extensions, FileList)
      end
      else if Pos(UpperCase(ExtractFileExt(SR.Name)), Extensions) > 0 then
        FileList.Add(Path + SR.Name);
    until
      FindNext(SR) <> 0;
  finally
    FindClose(SR);
  end;
end;

Usage:

GetFileList('c:\', '.PAS .FRM .DPR', MyStringList);

Change the desktop wallpaper through code

Problem/Question/Abstract:

Does anyone have any idea how to change the wallpaper background in Windows. Browsers can do it, but I have no idea how to do this in Delphi. I need to write an app which changes the background wallpaper on demand.

Answer:

Solve 1:

procedure TfrmWallpaperChanger.ChangeWallPaper(Bitmap: string);
var
  pBitmap: pchar;
begin
  bitmap := bitmap + #0;
  pBitmap := @bitmap[1];
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE);
end;


Solve 2:

procedure TForm1.Button1Click(Sender: TObject);
var
  St: array[0..100] of Char;
begin
  St := 'C:\Windows\MyWallPaper.bmp';
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @St, SPIF_SENDCHANGE);
end;


Solve 3:

You can easily change the wallpaper for a Windows 95/ NT system from a Delphi application. Here's the code:

procedure ChangeIt;
var
  Reg: TRegIniFile;
begin
  Reg := TRegIniFile.Create('Control Panel');
  Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\forest.bmp');
  Reg.WriteString('desktop', 'TileWallpaper', '1');
  Reg.Free;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

That's it! When you execute this procedure, you'll see the wallpaper change to the FOREST.BMP image. (This assumes that you're not using this image already.)


Solve 4:

The code below supports setting the exact position of the wallpaper and the ability to resize the wallpaper to fit the screen

uses
  Registry, WinProcs, SysUtils;

const
  {WallPaperStyles}
  WPS_Tile = 0;
  WPS_Center = 1;
  WPS_SizeToFit = 2;
  WPS_XY = 3;

  {sWallpaperBMPPath: Path to a BMP file
  nStyle: Any of the above WallPaperStyles
  nX, nY: If the nStyle is set to WPS_XY, nX and nY can be used to set the exact
               position of the wall paper}

procedure SetWallpaperExt(sWallpaperBMPPath: string; nStyle, nX, nY: integer);
var
  reg: TRegIniFile;
  s1: string;
  X, Y: integer;
begin
  {Change registry:

  HKEY_CURRENT_USER\
  Control Panel\Desktop
     TileWallpaper (REG_SZ)
     Wallpaper (REG_SZ)
     WallpaperStyle (REG_SZ)
     WallpaperOriginX (REG_SZ)
     WallpaperOriginY (REG_SZ)
  }
  reg := TRegIniFile.Create('Control Panel\Desktop');
  with reg do
  begin
    s1 := '0';
    X := 0;
    Y := 0;
    case nStyle of
      WPS_Tile: s1 := '1';
      WPS_Center: nStyle := WPS_Tile;
      WPS_XY:
        begin
          nStyle := WPS_Tile;
          X := nX;
          Y := nY;
        end;
    end;
    WriteString('', 'Wallpaper', sWallpaperBMPPath);
    WriteString('', 'TileWallpaper', s1);
    WriteString('', 'WallpaperStyle', IntToStr(nStyle));
    WriteString('', 'WallpaperOriginX', IntToStr(X));
    WriteString('', 'WallpaperOriginY', IntToStr(Y));
  end;
  reg.Free;
  {Let everyone know that we changed a system parameter}
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

Here are two examples on how to call the above SetWallpaperExt() function.

Set wallpaper to winnt.bmp and stretch it to fit the screen

SetWallpaperExt('c:\winnt\winnt.bmp', WPS_SizeToFit, 0, 0);

Set the wallpaper origin to (10, 200)

SetWallpaperExt('c:\winnt\winnt.bmp', WPS_XY, 10, 200);


Solve 5:

{ ... }
type
  TThemeWallpaperItem = record
    Filename: TFilename;
    Pattern: TFilename;
    Tile: Boolean;
    Style: TWallpaperStyle;
    ScreensaverActive: Boolean;
  end;

  TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper,
    wvWallpaperStyle, wvScreensaverActive);

const
  ThemeWallpaperSectionName = 'Control Panel\Desktop';
  ThemeWallpaperValueNames: array[TWallpaperValues] of string = ('Wallpaper',
    'Pattern', 'TileWallpaper', 'WallPaperStyle', 'ScreensaveActive');

procedure TThemeFile.WriteWallpaperToWindows;
var
  RegInifile: TRegIniFile;
const
  DefaultSectionName = 'Control Panel\Desktop';
begin
  RegInifile := TRegIniFile.Create;
  try
    RegIniFile.RootKey := HKEY_CURRENT_USER;
    {TWallpaperValues = (wvWallpaper, wvPattern, wvTileWallpaper, wvWallpaperStyle,
                                             wvScreensaverActive);}
    RegIniFile.WriteString(DefaultSectionName, ThemeWallpaperValueNames[wvWallpaper],
      FWallpaper.Filename);
    RegIniFile.WriteString(DefaultSectionName, ThemeWallpaperValueNames[wvPattern],
      FWallpaper.Pattern);
    RegIniFile.WriteBool(DefaultSectionName,
      ThemeWallpaperValueNames[wvTileWallpaper],
      FWallpaper.Tile);
    RegIniFile.WriteInteger(DefaultSectionName,
      ThemeWallpaperValueNames[wvWallPaperStyle],
      Integer(FWallpaper.Style))
  finally
    RegInifile.Free;
  end;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, SPI_SETDESKWALLPAPER,
    PChar(FWallpaper.Filename), SPIF_SENDCHANGE or
    SPIF_UPDATEINIFILE);
  SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Ord(FWallPaper.ScreensaverActive),
    nil, SPIF_SENDCHANGE or SPIF_UPDATEINIFILE);
  RefreshDesktop;
end;


Solve 6:

{ ... }
uses
  Registry, JPEG;

type
  TWallPaperStyle = (wpsCenter, wpsStretch, wpsTile);

const
  WALLPAPERSTYLESTRS: array[TWallPaperStyle] of string = ('Center', 'Stretch',
    'Tile');

function StrToWallPaperStyle(const s: string): TWallPaperStyle;
var
  wps: TWallPaperStyle;
begin
  result := wpsStretch;
  for wps := wpsCenter to wpsTile do
    if AnsiCompareText(s, WALLPAPERSTYLESTRS[wps]) = 0 then
    begin
      result := wps;
      exit;
    end;
end;

function RegGetWallPaperStyle: TWallPaperStyle;
var
  Reg: TRegistry;
  Center,
    Tile: boolean;
  s: string;
begin
  result := wpsStretch;
  Center := false;
  Tile := false;
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey('Control Panel\Desktop', false) then
    begin
      if Reg.ValueExists('TileWallpaper') then
      begin
        s := Reg.ReadString('TileWallpaper');
        Tile := (s = '1');
      end;
      if Reg.ValueExists('WallpaperStyle') then
      begin
        s := Reg.ReadString('WallpaperStyle');
        Center := (s = '0');
      end;
      if Tile then
        result := wpsTile
      else if Center then
        result := wpsCenter;
    end;
  finally
    Reg.Free;
  end;
end;

procedure RegSetWallPaperStyle(wps: TWallPaperStyle);
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey('Control Panel\Desktop', true) then
    begin
      case wps of
        wpsCenter:
          begin
            Reg.WriteString('TileWallpaper', '0');
            Reg.WriteString('WallpaperStyle', '0');
          end;
        wpsStretch:
          begin
            Reg.WriteString('TileWallpaper', '0');
            Reg.WriteString('WallpaperStyle', '2');
          end;
        wpsTile:
          begin
            Reg.WriteString('TileWallpaper', '1');
            {Reg.WriteString('WallpaperStyle', '0');}
          end;
      end;
    end;
  finally
    Reg.Free;
  end;
end;

procedure ChangeWallpaper(lpNewPaper: string; wps: TWallPaperStyle);
var
  Reg: TRegistry;
const
  SFolderKey = '\Control Panel\Desktop';
begin
  if not FileExists(lpNewPaper) or (CompareText('.bmp', ExtractFileExt(lpNewPaper)) <>
    0) then
    exit;
  Reg := TRegistry.Create;
  try
    if Reg.OpenKey(SFolderKey, false) then
    begin
      Reg.WriteString('Wallpaper', lpNewPaper);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  RegSetWallPaperStyle(wps);
  SystemParametersInfo(20, 0, PChar(lpNewPaper), $2);
end;

procedure SetWallpaper(const AFilename, NewFilename: string; wps:
  TWallPaperStyle);
var
  IsBitmapFile: boolean;
  bmp: TBitmap;
  pic: TPicture;
begin
  if FileExists(AFilename) then
  begin
    IsBitmapFile := AnsiCompareText('.bmp', ExtractFileExt(AFilename) = 0;
      if not IsBitmapFile then
      begin
        if (NewFilename = '') or (AnsiCompareText('.bmp', ExtractFileExt(NewFilename)
          <> 0) then
          raise Exception.Create('Wallpaper must be a bitmap file (*.bmp)');
          bmp := TBitmap.Create;
          try
            pic := TPicture.Create;
            try
              pic.LoadFromFile(AFilename);
              bmp.Assign(pic.Graphic);
            finally
              pic.Free;
            end;
            bmp.PixelFormat := pf24bit;
            bmp.SaveToFile(NewFilename);
            ChangeWallpaper(NewFilename, wps);
          finally
            bmp.Free;
          end;
      end
      else
        ChangeWallpaper(AFilename, wps);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  wps: TWallPaperStyle;
begin
  WallpaperCmbx.Clear; {TComboBox, style = csDropDownList, Sorted = false}
  for wps := wpsCenter to wpsTile do
    WallpaperCmbx.Items.Add(WALLPAPERSTYLESTRS[wps]);
  wps := RegGetWallPaperStyle;
  WallpaperCmbx.ItemIndex := ord(wps);
end;

procedure TForm1Button1Click(Sender: TObject);
var
  F, NewFName: string;
  wps: TWallPaperStyle;
begin
  with TOpenPictureDialog.Create(Self) do
  try
    if Execute then
    begin
      F := Filename;
      if AnsiCompareText('.bmp', ExtractFileExt(F)) <> 0 then
        NewFName := ChangeFileExt(F, '.bmp')
      else
        NewFName := '';
      wps := TWallPaperStyle(WallPaperCmbx.ItemIndex);
      SetWallpaper(F, NewFName, wps);
  finally
    Free;
  end;
end;

Show the property dialog for a file

Problem/Question/Abstract:

How can I show the property dialog for a file?

Answer:

procedure ShowPropertiesDialog(Filename: string);
var
  SEI: TShellExecuteInfo;
begin
  FillChar(SEI, SizeOf(SEI), 0);
  with SEI do
  begin
    cbSize := SizeOf(SEI);
    lpFile := PChar(Filename);
    lpVerb := 'properties';
    fMask := SEE_MASK_INVOKEIDLIST;
  end;
  ShellExecuteEx(@SEI);
end;

NT Native API

Problem/Question/Abstract:

NT Native API is basic API in Windows NT/2000. All other API (Win32 is included) are use this API. But functions from ntdll.dll are poorely documented.

Answer:

You can download full source code (ntdll.pas is included):
  http://homepages.mtgroup.ru/alexk/files/NativeApp.zip

Unit ntdll.pas contains only definitions for some functions and structures from NT Native API.

program NativeApp;

// PURPOSE: Simple Windows NT/2000 console application that calls
// Native API functions

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, ntdll;

type
  TEnumNtObjectCallBack = function(
    pusObjectName: PNtUnicodeString;
    ObjectTypeName: string;
    DirectoryHandle: THandle;
    UserData: Pointer
    ): Boolean; // False => stop

  //-------------------------------------------------------------

function NtUnicodeStringToString(pusString: PNtUnicodeString): string;
var
  asString: TNtAnsiString;
begin
  Result := '';
  if (pusString = nil) or (pusString^.Length = 0) then
    Exit;
  // convert with allocating
  RtlUnicodeStringToAnsiString(@asString, pusString, True);
  try
    SetString(Result, asString.Buffer, asString.Length);
  finally
    RtlFreeAnsiString(@asString); // free allocated memory
  end;
end;
//-------------------------------------------------------------
// Open any named NT object.
// If DirectoryHandle=0 then ObjectName must be full qualified name
// (start with backslash symbol),
// otherwise ObjectName specify relative path from this directory
// You must call CloseHandle to free obtained handle.

function OpenObject(ObjectName: PNtUnicodeString;
  DirectoryHandle: THandle;
  DesireAccess: ACCESS_MASK): THandle;
var
  ObjectAttributes: TNtObjectAttributes;
  IoStatus: TIoStatusBlock;
  doserr: DWORD;
  rc: NTSTATUS;
begin
  InitializeObjectAttributes(@ObjectAttributes, ObjectName,
    OBJ_CASE_INSENSITIVE, DirectoryHandle, nil);
  rc := NtOpenFile(Result, DesireAccess, ObjectAttributes, IoStatus,
    FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE, 0);
  if rc <> STATUS_SUCCESS then
  begin
    doserr := RtlNtStatusToDosError(rc);
    SetLastError(doserr);
    Result := INVALID_HANDLE_VALUE;
  end;
end;
//-------------------------------------------------------------
// Open directory and call Treate function for all objects
// in this directory.

function EnumNtObjects(Path: string;
  Treate: TEnumNtObjectCallBack;
  UserData: Pointer): NTSTATUS;
const
  BufferSize = 2048;
var
  hDir: THandle;
  doserr: DWORD;
  DirObject: TNtObjectAttributes;
  asDirName: TNtAnsiString;
  usDirName: TNtUnicodeString;
  cbBytesReturned: DWORD;
  dwIndex: DWORD;
  Buffer: array[0..BufferSize - 1] of Byte;
  DirInfo: TDirectoryInformationTYpe1 absolute Buffer;
  FileNameInfo: TFileNameInformation absolute Buffer;
begin
  if not Assigned(Treate) or (Path = '') then
  begin
    Result := STATUS_INVALID_PARAMETER;
    Exit;
  end;
  RtlInitAnsiString(@asDirName, PChar(Path));
  RtlAnsiStringToUnicodeString(@usDirName, @asDirName, True);
  try
    InitializeObjectAttributes(@DirObject, @usDirName,
      OBJ_CASE_INSENSITIVE, 0, nil);
    hDir := 0;
    Result := NtOpenDirectoryObject(hDir,
      DIRECTORY_TRAVERSE or DIRECTORY_QUERY, DirObject);
    if Result <> STATUS_SUCCESS then
    begin
      doserr := RtlNtStatusToDosError(Result);
      SetLastError(doserr);
    end
    else
    try
      dwIndex := 0;
      repeat
        Result := NtQueryDirectoryObject(hDir,
          @Buffer, BufferSize,
          TDirectoryInformationClass(1), // ???
          False, dwIndex, cbBytesReturned);
        if Result <> 0 then
        begin
          if Result = STATUS_NO_MORE_DATA then
          begin
            Result := STATUS_SUCCESS;
            Break;
          end;
          doserr := RtlNtStatusToDosError(Result);
          SetLastError(doserr);
          Break;
        end;
      until not Treate(@DirInfo.ObjectName,
        NtUnicodeStringToString(@DirInfo.ObjectTypeName),
        hDir, UserData);
    finally
      CloseHandle(hDir);
    end;
  finally
    RtlFreeUnicodeString(@usDirName);
  end;
end;

//=============================================================
// Sample for EnumNtObjects callback function
type
  TUserData = record
    DesireObjectType: PChar;
    DesireAccess: ACCESS_MASK;
  end;
  PUserData = ^TUserData;

function EnumNtObjectsCallBack(pusObjectName: PNtUnicodeString;
  ObjectTypeName: string;
  DirectoryHandle: THandle;
  UserData: Pointer): Boolean;
var
  sObjectName: string;
  hObject: THandle;
begin
  Result := True;
  sObjectName := NtUnicodeStringToString(pusObjectName);
  with PUserData(UserData)^ do
    if (DesireObjectType <> '*')
      and (CompareText(ObjectTypeName, DesireObjectType) <> 0) then
      Exit;
  if (CompareText(ObjectTypeName, 'Directory') = 0)
    //NtOpenDirectoryObject
  or (CompareText(ObjectTypeName, 'Type') = 0)
    or (CompareText(ObjectTypeName, 'Port') = 0)
    or (CompareText(ObjectTypeName, 'Key') = 0) // NtOpenKey
  or (CompareText(ObjectTypeName, 'Event') = 0) // OpenEvent
  or (CompareText(ObjectTypeName, 'Semaphore') = 0) // OpenSemaphore
  or (CompareText(ObjectTypeName, 'Mutant') = 0) // OpenMutex
  or (CompareText(ObjectTypeName, 'Timer') = 0) // NtOpenTimer
  or (CompareText(ObjectTypeName, 'Section') = 0) // NtOpenSection
  or (CompareText(ObjectTypeName, 'SymbolicLink') = 0)
    {// NtOpenSymbolicLinkObject } then
  begin
    WriteLn(ObjectTypeName, ' ', sObjectName);
    Exit;
  end;
  hObject := OpenObject(pusObjectName, DirectoryHandle,
    PUserData(UserData)^.DesireAccess);
  if hObject = INVALID_HANDLE_VALUE then
  begin
    Write('  NtOpenObject failed for ', sObjectName, ': ');
    WriteLn(SysErrorMessage(GetLastError));
    Exit;
  end;
  try
    WriteLn(ObjectTypeName, ' ', sObjectName,
      ' is opened successfully');

    // do something with object here

  finally
    CloseHandle(hObject);
  end;
end;

//=============================================================
// Application

var
  sObjectType, sPath: string;
  rUserData: TUserData;
begin
  if (ParamCount = 0) or (ParamCount > 2) then
  begin
    WriteLn('(c) 20 jul 2000 Alex Konshin mailto:alexk@mtgroup.ru');
    WriteLn;
    WriteLn('Sample console application that use NT Native API.');
    WriteLn;
    WriteLn('Using:');
    WriteLn;
    WriteLn('  NativeApp ObjectType [Path]');
    WriteLn;
    WriteLn('Where:');
    WriteLn;
    WriteLn('  ObjectType = *(all objects), Directory, Type, Device, Mutant,');
    WriteLn('        Section, Semaphore,...');
    WriteLn('        (use NativeApp Type \ObjectTypes to list NT object types)');
    WriteLn;
    WriteLn('  Path = NT objects directory name.');
    WriteLn;
    WriteLn('Examples:');
    WriteLn;
    WriteLn('  NativeApp Device \Device');
    WriteLn('  NativeApp Mutant \BaseNamedObjects');
    WriteLn;
    Exit;
  end;
  sObjectType := ParamStr(1);
  sPath := ParamStr(2);
  if sPath = '' then
    sPath := '\';
  with rUserData do
  begin
    DesireObjectType := PChar(sObjectType);
    DesireAccess := FILE_READ_DATA; // GENERIC_READ or GENERIC_WRITE;
  end;
  EnumNtObjects(sPath, EnumNtObjectsCallBack, @rUserData);
end.

Links for more informations:
  http://www.sysinternals.com/ntdll.htm
  http://www.sysinternals.com/winobj.htm

Books:
  http://www.amazon.com/exec/obidos/ASIN/1578701996/systemsinternals

See also Zw*, Rtl* functions descriptions in Win2000 DDK.

Check how many COM ports are available

Problem/Question/Abstract:

How to check how many COM ports are available

Answer:

Solve 1:

function ExtComName(ComNr: DWORD): string;
begin
  if ComNr > 9 then
    Result := Format('\\\\.\\COM%d', [ComNr])
  else
    Result := Format('COM%d', [ComNr]);
end;

function CheckCom(AComNumber: Integer): Integer;
var
  FHandle: THandle;
begin
  Result := 0;
  FHandle := CreateFile(PChar(ExtComName(AComNumber)),
    GENERIC_READ or GENERIC_WRITE,
    0, {exclusive access}
    nil, {no security attrs}
    OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL,
    0);
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle)
  else
    Result := GetLastError;
end;

var
  XX, Err: Integer;

  for XX := 1 to 20 do
  begin
    Err := CheckCom(XX);
    if (Err = 0) or (Err = ERROR_ACCESS_DENIED) then
      {the Port exists, if  Err = ERROR_ACCESS_DENIED then the port is already open}
    else if (Err = ERROR_FILE_NOT_FOUND) then
      {the Port does not exists}
    else
      {another Error}
  end;


Solve 2:

The following bit of code checks both the Comm Ports and the JoyStick Ports, placing them in a combobox. Those which were used were displayed grey and those free were displayed black. A log message was constructed during the enumeration and could be displayed to show what was found. The comm ports are held in two places in the registry and are slightly different for Win9? and NT.

procedure GetCommNames(CommNames: TStringList);
{searches the *PNP0501 and SerialComm entries in the registry fo commport names}
var
  Reg: TRegistry;
  SerPtSL: TStringList;
  i: integer;
  CommStr: string;
const
  CommPNPKey: string = '\Enum\BIOS\*PNP0501';
  HardwareKey: string = '\hardware\devicemap\serialcomm';
begin
  {stringlist to hold key or value names during search}
  SerPtSL := TStringList.Create;
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    LogStr := LogStr + '  HKEY_LOCAL_MACHINE' + #13;
    {check PNP entries}
    if OpenKey(CommPNPKey, false) then
    begin
      LogStr := Format('%s  %s opened%s', [LogStr, CommPNPKey, #13]);
      {get all serial port keys - one key for each interupt used}
      GetKeyNames(SerPtSL);
      {get the Comm names for all the keys - into CommSL}
      for i := 0 to SerPtSL.Count - 1 do
      begin
        OpenKey(CommPNPKey + '\' + SerPtSL.Strings[i], false);
        if GetDataType('PortName') = rdString then
        begin
          CommNames.Add(ReadString('PortName'));
          LogStr := Format('%s  %s%s', [LogStr, CommNames.Strings[i], #13]);
        end;
      end;
    end
    else
      LogStr := LogStr + '  Unable to open ' + CommPNPKey + #13;
    SerPtSL.Clear; {to use for hardware value names}
    {check the hardware entries}
    if OpenKey(HardwareKey, false) then
    begin
      LogStr := Format('%s  %s opened%s', [LogStr, HardwareKey, #13]);
      {get the value names for the commports - NT is "Serialn" W95 is "COMn"}
      GetValueNames(SerPtSL);
      {now get the data value for each commport}
      for i := 0 to SerPtSL.Count - 1 do
        if GetDataType(SerPtSL.Strings[i]) = rdString then
        begin
          CommStr := ReadString(SerPtSL.Strings[i]);
          LogStr := LogStr + '    ' + CommStr;
          {if it's not in CommNames already ...}
          if CommNames.IndexOf(CommStr) < 0 then
          begin
            {... add it}
            CommNames.Add(CommStr);
            LogStr := LogStr + ' added' + #13;
          end
          else
            LogStr := LogStr + ' already in list' + #13;
        end;
    end
    else
      LogStr := Format('%s  Unable to open %s', [LogStr, HardwareKey, #13]);
    Free; {TRegistry}
  end;
  SerPtSL.Free;
end;

procedure TForm1.GetComBtnClick(Sender: TObject);
{this is the initiator of the "fill combobox with com ports" action}
var
  PortList: TStringList;
begin
  LogStr := '';
  LogBtn.Enabled := false;
  PortList := TStringList.Create;
  GetAvailableJoyPort(PortList);
  GetAvailableCommPorts(PortList);
  with PortComboBox do
  begin
    {put the stringlist into the combobox}
    Items.Assign(PortList);
    {select the first available port to show}
    ItemIndex := PortComboBox.Items.IndexOfObject(pointer(true));
    if Pos('COM', Items[ItemIndex]) > 0 then
      EnableDCBBtns(ItemIndex > -1);
    Enabled := true;
  end;
  PortList.Free;
  LogBtn.Enabled := true;
end;

procedure TForm1.GetAvailableJoyPort(JoyList: TStringList);
{gets the joystick ports - they are available only if a joystick is plugged in}
var
  Res: DWord;
begin
  LogStr := 'JoyPort' + #13;
  Res := JoySetCapture(Self.Handle, JOYSTICKID1, 0, true);
  JoyReleaseCapture(JOYSTICKID1);
  case Res of
    JOYERR_NOERROR:
      begin
        JoyList.AddObject('Joystick', pointer(true));
        LogStr := LogStr + '  OK : JOYERR_NOERROR' + #13;
      end;
    JOYERR_PARMS:
      LogStr := LogStr + '  Error : JOYERR_PARMS' + #13;
    JOYERR_NOCANDO:
      LogStr := LogStr + '  Error : JOYERR_NOCANDO' + #13;
    JOYERR_UNPLUGGED:
      begin
        JoyList.AddObject('Joystick', pointer(false));
        LogStr := LogStr + '  Eror : JOYERR_UNPLUGGED' + #13;
      end;
  else
    LogStr := Format('%s  Unknown Error : %d%s', [LogStr, Res, #13]);
  end;
end;

procedure TForm1.GetAvailableCommPorts(ComList: TStringList);
{puts the COM ports into a list. available ports have the stringlist objects
set to a non-nil value. to be available the ports must be a hardware port (in
the registry list comm ports) and have a ProviderSubType of PST_RS232}
var
  CommSL: TStringList;
  CommName: string;
  hComm: THandle;
  PtrCommConfig: PCommConfig;
  i, CommConfigSize: integer;
  Available: boolean;
begin
  LogStr := LogStr + 'CommPorts' + #13;
  CommSL := TStringList.Create;
  GetCommNames(CommSL);
  LogStr := Format('%s  %d Different CommPorts Found in Registry%s',
    [LogStr, CommSL.Count, #13]);
  LogStr := Format('%sOpening Ports as a File%s', [LogStr, #13]);
  {CommSL now contains the list of commports from the registry}
  for i := 0 to CommSL.Count - 1 do
  begin
    CommName := CommSL.Strings[i]; {Format('COM%d', [i]);}
    Available := false;
    LogStr := LogStr + '    ' + CommName + ' : ';
    {open the port as a file}
    hComm := CreateFile(PChar(CommName), GENERIC_READ or GENERIC_WRITE,
      0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    if hComm <> INVALID_HANDLE_VALUE then
    begin
      {its a useable COM port - check if its an RS232 type}
      CommConfigSize := SizeOf(TCommConfig);
      PtrCommConfig := AllocMem(CommConfigSize);
      if not GetCommConfig(hComm, PtrCommConfig^, CommConfigSize) then
      begin
        {not enough memory - get what's needed}
        ReAllocMem(PtrCommConfig, CommConfigSize);
        GetCommConfig(hComm, PtrCommConfig^, CommConfigSize);
      end;
      Available := (PtrCommConfig^.dwProviderSubType = PST_RS232);
      if Available then
        LogStr := LogStr + 'PST_RS232' + #13
      else
        LogStr := Format('%sdwProviderSubType : %d%s', [LogStr,
          PtrCommConfig^.dwProviderSubType, #13]);
      FreeMem(PtrCommConfig);
    end
    else
    begin
      Available := false;
      LogStr := LogStr + ' Not Available - INVALID_HANDLE_VALUE' + #13;
    end;
    CloseHandle(hComm);
    ComList.AddObject(CommName, pointer((Available)))
  end;
  CommSL.Free;
end;

procedure TForm1.PortComboBoxDrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
{draws items in gray if the Items.Objects[n] is nil, in black if it is <> nil}
begin
  with PortComboBox do
  begin
    if not bool(Items.Objects[Index]) then
    begin
      {item is not available ...}
      Canvas.Brush.Color := clWhite; { never indicate as selected}
      Canvas.Font.Color := clBtnFace; {grey out text}
    end;
    {now draw background and text}
    Canvas.FillRect(Rect);
    Canvas.TextOut(Rect.Left, Rect.Top, Items[Index]);
  end;
end;


Solve 3:

This checks for LPT1:

uses
  WinSpool;

type
  TArrayPORT_INFO_1 = array[0..0] of PORT_INFO_1;
  PArrayPORT_INFO_1 = ^TArrayPORT_INFO_1;

procedure LPT1Check();
var
  apiBuffer: PArrayPORT_INFO_1;
  lwBufferSize: LongWord;
  lwPortCount: LongWord;
  lwIndex: LongWord;
  sMessage: string;
begin
  {Find required size of the buffer}
  EnumPorts(nil, 1, nil, 0, lwBufferSize, lwPortCount);
  {Alloc and fill buffer}
  apiBuffer := AllocMem(lwBufferSize);
  EnumPorts(nil, 1, apiBuffer, lwBufferSize, lwBufferSize, lwPortCount);
  {Search returned buffer}
  {Using word so must check for 0 as 0 - 1 = 4294967295  not -1!}
  if lwPortCount = 0 then
    sMessage := 'No ports installed on this system'
  else
  begin
    sMessage := 'LPT1: not found on this system';
    for lwIndex := 0 to lwPortCount - 1 do
    begin
      if UpperCase(apiBuffer[lwIndex].pName) = 'LPT1:' then
      begin
        sMessage := 'LPT1: exists';
        Break;
      end;
    end;
  end;
  {Free the buffer and show result}
  FreeMem(apiBuffer);
  ShowMessage(sMessage);
end;

Access and control a NT service

Problem/Question/Abstract:

The unit described in this article show how we can start or stop a NT service by programming, or getting the location of its binary implentation.

Answer:

unit SvcUtils;

// Written by Bertrand Goetzmann (http://www.object-everywhere.com)
// Keywords : Service, OpenSCManager, OpenService, CloseServiceHandle, QueryServiceConfig, StartService, QueryServiceStatus, ControlService

interface

// This function returns the entire path location of the implementation of the given name service
function GetBinaryPathName(const ServiceName: string): string;

// This function starts the service with the given service name
procedure StartService(const ServiceName: string);

// This function stops the service with the given service name
procedure StopService(const ServiceName: string);

implementation

uses SysUtils, WinSvc;

function GetBinaryPathName(const ServiceName: string): string;
var
  SvcMgr, Svc: Integer;
  QuerySvc: TQueryServiceConfig;
  BytesNeeded: Cardinal;

  Buffer: PQueryServiceConfig;
begin
  // Establish a connection to the service control manager
  SvcMgr := OpenSCManager(nil {*MachineName*}, nil {*DatabaseName*},
    SC_MANAGER_ALL_ACCESS);
  try
    if SvcMgr = 0 then
      RaiseLastOSError;

    Svc := OpenService(SvcMgr, PChar(ServiceName), SERVICE_ALL_ACCESS);
    if Svc = 0 then
      RaiseLastOSError;
    try
      // Make a call to know the number of bytes needed
      QueryServiceConfig(Svc, @QuerySvc, 0, BytesNeeded);

      GetMem(Buffer, BytesNeeded);
      try
        if not QueryServiceConfig(Svc, Buffer, BytesNeeded, BytesNeeded) then
          RaiseLastOSError;

        Result := PQueryServiceConfig(Buffer).lpBinaryPathName;
      finally
        FreeMem(Buffer);
      end;
    finally
      CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

procedure StartService(const ServiceName: string);
var
  SvcMgr, Svc: Integer;
  ServiceArgVectors: PChar;
begin
  // Establish a connection to the service control manager
  SvcMgr := OpenSCManager(nil {*MachineName*}, nil {*DatabaseName*},
    SC_MANAGER_ALL_ACCESS);
  try
    if SvcMgr = 0 then
      RaiseLastOSError;

    Svc := OpenService(SvcMgr, PChar(ServiceName), SERVICE_ALL_ACCESS);
    if Svc = 0 then
      RaiseLastOSError;
    try
      if not WinSvc.StartService(Svc, 0 {*NumServiceArgs*}, ServiceArgVectors) then
        RaiseLastOSError;
    finally
      CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

procedure StopService(const ServiceName: string);
var
  SvcMgr, Svc: Integer;
  ServiceStatus: _SERVICE_STATUS;
begin
  // Establish a connection to the service control manager
  SvcMgr := OpenSCManager(nil {*MachineName*}, nil {*DatabaseName*},
    SC_MANAGER_ALL_ACCESS);
  try
    if SvcMgr = 0 then
      RaiseLastOSError;

    Svc := OpenService(SvcMgr, PChar(ServiceName), SERVICE_ALL_ACCESS);
    if Svc = 0 then
      RaiseLastOSError;
    try
      // if not QueryServiceStatus(Svc, ServiceStatus) then
      //  RaiseLastOSError;
      // You can test the ServiceStatus.dwCurrentState field

      if not ControlService(Svc, SERVICE_CONTROL_STOP, ServiceStatus) then
        RaiseLastOSError;
    finally
      CloseServiceHandle(Svc);
    end;
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

end.

FAQ:

As do to register my application as a service?

You can register your service application simply by executing it with the /INSTALL option.

How to pass multi-arguments to StartService?

You can pass some argument with the starting of a service with the call of the StartService function of the Win32 API. The StartService procedure of the SvcUtils unit makes a such call with 0 argument :

WinSvc.StartService(Svc, 0 (*NumServiceArgs*), ServiceArgVectors)

What is RaiseLastOSError?

RaiseLastOSError is a function from the SysUtils unit that permits to raise an exception for the last operating system error or library system error.

I did know how to manage this, but I'm looking for a way to have the list of all installed services. Do you have a solution for that?

I think that the EnumServicesStatus function from the Windows API is the solution.
The function enumerates services in the specified service control manager database. The name and status of each service are provided.

The code looks very nice, but one problem; what is it suposed to do?? Any insight on what this program can do to benefit us would be greatly apprecaited!

On the Windows NT plateform you can look all the installed services by executing MMC (Microsoft Managment Console). All these services can be handled by this GUI application (start, stop, suspend, etc.).
This article show the use of some of the Service Functions from the Window API to do the same things by programming