Delphi控件源码

开发平台：
C++ Builder

RegForm.pas：源码内容
							unit RegForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, StdCtrls, FileCtrl, ComCtrls, WinSvc, Grids, Outline, DirOutln;
type
  TPPInstallForm = class(TForm)
    btnInsert: TButton;
    btnCleanUp: TButton;
    BitBtn1: TBitBtn;
    DirectoryListBox1: TDirectoryListBox;
    DriveComboBox1: TDriveComboBox;
    btnLocateDLL: TButton;
    m_OpenDLLDialog: TOpenDialog;
    Button1: TButton;
    GroupBox1: TGroupBox;
    l_strDLLPath: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    l_strTempPath: TLabel;
    Button2: TButton;
    procedure BitBtn1Click(Sender: TObject);
    procedure btnInsertClick(Sender: TObject);
    procedure btnCleanUpClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DriveComboBox1Change(Sender: TObject);
    procedure DirectoryListBox1Click(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure btnLocateDLLClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    m_strDLLSrcDir : string;
    m_strTempVar : string;
    m_bSrcFound : boolean;
    lpszTempDir : PChar;
    strTempDir : string;
  end;
var
  PPInstallForm: TPPInstallForm;
implementation
Uses
  WinReg;
{$R *.DFM}
// define a constant to hold our registry key
const
  PMON_KEY = 'SYSTEMCurrentControlSetControlPrintEnvironmentsWindows NT x86Print Processors';
  TEMP_KEY = 'SYSTEMCurrentControlSetControlSession Manager';
procedure TPPInstallForm.BitBtn1Click(Sender: TObject);
begin
  Close;
end;
//
// start and stop software routines
// taken from http://www.chami.com/tips/delphi/040698D.html
//
// start service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \SERVER
//   empty = local machine
//
// sService
//   service name, ie: spooler
//
function ServiceStart(sMachine, sService : string ) : boolean;
  var
    schm, schs : SC_Handle;  // service control manager handle & service handle
    ss : TServiceStatus;  // service status
    psTemp : PChar; // temp char pointer
    dwChkP : DWord;   // check point
  begin
    ss.dwCurrentState := 0;
    // connect to the service control manager
    schm := OpenSCManager(PChar(sMachine), Nil, SC_MANAGER_CONNECT);
    // if successful...
    if(schm > 0)then begin
      // open a handle to the specified service
      // we want to start the service and query service status
      schs := OpenService(schm, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
      // if successful...
      if(schs > 0)then begin
        psTemp := Nil;
        if(StartService(schs, 0, psTemp)) then begin
          // check status
          if (QueryServiceStatus(schs, ss))then begin
            while (SERVICE_RUNNING <> ss.dwCurrentState)do begin
              //
              // dwCheckPoint contains a value that the service increments periodically
              // to report its progress during a lengthy operation.
              // save current value
              dwChkP := ss.dwCheckPoint;
              // wait a bit before checking status again
              //
              // dwWaitHint is the estimated amount of time
              // the calling program should wait before calling
              // QueryServiceStatus() again
              //
              // idle events should be
              // handled here...
              //
              Sleep(ss.dwWaitHint);
              if (not QueryServiceStatus(schs, ss))then begin
                // couldn't check status
                // break from the loop
                break;
              end;
              if (ss.dwCheckPoint < dwChkP) then begin
                // QueryServiceStatus didn't increment dwCheckPoint as it should have.
                // avoid an infinite loop by breaking
                break;
              end;
            end;
          end;
        end;
        // close service handle
        CloseServiceHandle(schs);
      end;
      // close service control manager handle
      CloseServiceHandle(schm);
  end;
  // return TRUE if the service status is running
  Result := SERVICE_RUNNING = ss.dwCurrentState;
end;
//
// stop service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//
function ServiceStop(sMachine, sService : string ) : boolean;
  var
    schm, schs   : SC_Handle; // service control & service handle manager handle
    ss : TServiceStatus; // service status
    dwChkP : DWord; // check point
  begin
    // connect to the service control manager
    schm := OpenSCManager(PChar(sMachine), Nil, SC_MANAGER_CONNECT);
    // if successful...
    if (schm > 0) then begin
      // open a handle to the specified service
      // we want to stop the service and query service status
      schs := OpenService(schm, PChar(sService), SERVICE_STOP or SERVICE_QUERY_STATUS);
      // if successful...
      if (schs > 0) then begin
        if (ControlService(schs, SERVICE_CONTROL_STOP, ss)) then begin
          // check status
          if (QueryServiceStatus(schs, ss)) then begin
            while (SERVICE_STOPPED <> ss.dwCurrentState) do begin
              // dwCheckPoint contains a value that the service increments periodically
              // to report its progress during a lengthy operation.
              //
              // save current value
              //
              dwChkP := ss.dwCheckPoint;
              //
              // wait a bit before checking status again
              //
              // dwWaitHint is the estimated amount of time
              // the calling program should wait before calling QueryServiceStatus() again
              //
              // idle events should be handled here...
              //
              Sleep(ss.dwWaitHint);
              if (not QueryServiceStatus(schs, ss)) then begin
                // couldn't check status
                // break from the loop
                break;
              end;
              if (ss.dwCheckPoint < dwChkP) then begin
                // QueryServiceStatus didn't increment dwCheckPoint as it should have.
                // avoid an infinite loop by breaking
                break;
              end;
            end;
          end;
        end;
        // close service handle
        CloseServiceHandle(schs);
      end;
      // close service control  manager handle
      CloseServiceHandle(schm);
    end;
    // return TRUE if  the service status is stopped
    Result := SERVICE_STOPPED = ss.dwCurrentState;
  end;
function GetWinDir : string;
var
  lpszDir : PChar;
  strTmp : string;
begin
  GetMem(lpszDir, 255);
  GetEnvironmentVariable('windir', lpszDir, 255);
  strTmp := string(lpszDir);
  FreeMem(lpszDir);
  GetWinDir := strTmp;
end;
procedure TPPInstallForm.btnInsertClick(Sender: TObject);
var
  reg : TWinRegistry;
  DLLString, VerString, DestDirString : string;
  strWinDir : string;
begin
  if MessageDlg('Really install?', mtConfirmation, mbOKCancel, 0) = mrOk then begin
    // open the registry using the default root of HKEY_CURRENT_USER
    reg := TWinRegistry.CreateWithKey(HKEY_LOCAL_MACHINE, PMON_KEY);
    // initialise the variables
    DLLString := 'vprproc.dll';
    VerString := '1.0';
    DestDirString := l_strTempPath.Caption;
    // write the variables to the registry
    with reg do begin
      WriteString('vprproc', 'Driver', DLLString);
      WriteString('vprproc', 'Version', VerString);
      WriteString('vprproc', 'DestDir', DestDirString);
    end;
    reg.Free;
    ShowMessage('Registry Keys installed.');
    // copy dll into dest directory if dll is specified
    if (FileExists(m_strDLLSrcDir) = True) and (m_strDLLSrcDir <> '') then begin
      strWinDir := GetWinDir;
      if (strWinDir[Length(strWinDir)] <> '') then strWinDir := Concat(strWinDir, '');
      strWinDir := Concat(strWinDir, 'system32spoolprtprocsw32x86vprproc.dll');
      ShowMessage('Now stopping spooler service.');
      if (ServiceStop('', 'spooler')) then begin
        ShowMessage('Copying '+ m_strDLLSrcDir+ ' to ' + strWinDir + ' .');
        CopyFile(PChar(m_strDLLSrcDir), PChar(strWinDir), False);
        ShowMessage('Now starting spooler service.');
        if not ServiceStart('', 'spooler') then
          ShowMessage('Could not start spooler service.' + #13 + 'Please uninstall driver and try again.')
        else
          ShowMessage('Printer Processor installed.');
      end else
        ShowMessage('Could not stop spooler service. ' + #13 + 'Please start spooler service manually and try again.');
    end;
  end;
end;
procedure TPPInstallForm.btnCleanUpClick(Sender: TObject);
var
  reg : TWinRegistry;
  strWinDir : string;
begin
  if MessageDlg('Really uninstall?', mtConfirmation, mbOKCancel, 0) = mrOk then begin
    ShowMessage('Stopping spooler service.');
    if (ServiceStop('', 'spooler')) then begin
      reg := TWinRegistry.CreateWithKey(HKEY_LOCAL_MACHINE, PMON_KEY);
      reg.EraseSection('vprproc');
      reg.Free;
    end;
    if MessageDlg('Registry keys for VPrinter deleted. Delete vprproc.dll?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
      strWinDir := GetWinDir;
      if (strWinDir[Length(strWinDir)] <> '') then strWinDir := Concat(strWinDir, '');
      strWinDir := Concat(strWinDir, 'system32spoolprtprocsw32x86vprproc.dll');
      DeleteFile(strWinDir);
    end;
    ShowMessage('All actions done. Now restarting spooler service.');
    ServiceStart('', 'spooler' );
    ShowMessage('Spooler service restarted.');
  end;
end;
procedure TPPInstallForm.FormCreate(Sender: TObject);
var reg : TWinRegistry;
begin
  m_strDLLSrcDir := '';
  m_bSrcFound := False;
  // look if environment is defined
  reg := TWinRegistry.CreateWithKey(HKEY_LOCAL_MACHINE, PMON_KEY);
  m_strTempVar := reg.ReadString('vprproc', 'DestDir', '');
  if (m_strTempVar = '') then begin
    ShowMessage('vprproc registry settings not yet set!' + #13 + 'Please select destination directory for print jobs.');
    btnInsert.Enabled := False;
  end else if not(DirectoryExists(m_strTempVar)) then begin
    ShowMessage('Inappropriate Registry Settings. Please reinstall!');
    l_strTempPath.Caption := m_strTempVar;
  end else
    l_strTempPath.Caption := m_strTempVar;
  reg.Free;
  if l_strTempPath.Caption<>'' then
    if DirectoryExists(l_strTempPath.Caption) then begin
     {$I-}
     DriveComboBox1.Drive := (ExpandFileName(l_strTempPath.Caption))[1];
     DirectoryListBox1.Directory := l_strTempPath.Caption;
     if IOResult <> 0 then MessageDlg('No temp directory specified.', mtError, [mbOk], 0);
     {$I+}
    end;
end;
procedure TPPInstallForm.DriveComboBox1Change(Sender: TObject);
begin
  DirectoryListBox1.Directory := DriveComboBox1.Drive
end;
procedure TPPInstallForm.DirectoryListBox1Click(Sender: TObject);
begin
  l_strTempPath.Caption := DirectoryListBox1.Directory;
end;
procedure TPPInstallForm.DirectoryListBox1Change(Sender: TObject);
begin
  l_strTempPath.Caption := DirectoryListBox1.Directory;
  btnInsert.Enabled := True;
end;
procedure TPPInstallForm.btnLocateDLLClick(Sender: TObject);
begin
  ShowMessage('Choose the appropriate DLL: select vproc.dll' + #13 +
              'from the w2k directory if you use Windows 2000 or vprproc.dll' + #13 +
              'from the xp directory if you use Windows XP.');
  if m_OpenDLLDialog.Execute then begin
    m_strDLLSrcDir := m_OpenDLLDialog.FileName;
    l_strDLLPath.Caption := m_OpenDLLDialog.FileName;
    m_bSrcFound := True;
  end else begin
    l_strDLLPath.Caption := '<empty>';
    m_strDLLSrcDir := '';
    m_bSrcFound := False;
  end;
end;
procedure TPPInstallForm.Button1Click(Sender: TObject);
begin
  ShowMessage('To reinstall print processor dll, locate vprproc.dll by pressing ''Locate DLL'' button.' + #13 +
              'Choose the appropriate dll for Windows 2000 or XP.' + #13 +
              'If you don''t want to reinstall, leave Locate field <empty>' + #13 +
              'To install dll (if specified) and registry keys, press ''Install'' button' + #13 +
              'To uninstall registry keys and to delete vprproc.dll, press ''Uninstall'' button.');
end;
procedure TPPInstallForm.Button2Click(Sender: TObject);
begin
  MessageDlg('Print Processor Installer Tool' + #13 + '(C) 2002 mabuse.de', mtInformation, [mbOK], 0);
end;
end.

						