regfiles.pas

大家是不是为不知道如何在VB学到绝地程序

{***************************************************************
 *
 * Unit Name   : RegFiles
 * Version     : 1.0.0.0
 * Date        : 2000-02-02
 * Purpose     : File Association
 * Author      : riceball ([e-mail])
 * Copyright(C): 2000 by riceball
 * History     :
 *         2000-02-02 星期三
 *            First Release
 *         2000-07-22
 *            + UpdateAssociationToSystem
 *            * Smart Delete and Create Association(it can keep and restore old default)
 *            * function GetRegSubTree(MainKey: LongInt; aKey, aValue: string;const aList: TStrings) : Boolean;
 *                Support apart match
 *         2000-07-24
 *            + procedure UpdateAssociationPath(KeyName, FileName: string);
 *              Check AssociationPath and update Path
 *
 *
 ****************************************************************}

Unit RegFiles;

Interface

Uses
  Windows,
  SysUtils,
  Dialogs,
  Classes,
  Registry,
  ShellAPI,
  ShlObj;

Procedure UpdateAssociationToSystem;

//Check AssociationPath and update Path
Procedure UpdateAssociationPath(Const KeyName, FileName: String);

//Set a value in the registry;
Procedure SetValInReg(RKey: HKey; KeyPath: String; ValName: String; NewVal: String);

Procedure RegisterAllFileType(MenuName, Command: String);
{Click on a File in Explorer with right mouse key ,
uses this function you may add new menu item to popup menu
MenuName:display on the popup menu name
Command: execute command
eg:
RegisterAllFileType(sFileMenuName, '"' + Application.ExeName + '" "%1"');
}

Procedure UnRegisterAllFileType(MenuName: String);

Function ExtDescription(Ext: String): String;
{if ExtDescription(File type description) then return such description}

Function AssociationExists(Ext: String; Var FileName: String): String;
{ Ext: Extension Name (eg: ".txt")
  if no AssociationExists then return ''
  else return Association Key Name and Execute File Name
}

Function DoesKeyExist(AKey: String): Boolean;
Function DeleteAssociation(RegKey, Ext: String): Boolean;
{ Desc: if old association exists then fisrt restore old one , then delete.
}
Function ClearAssociation(RegKey, Ext: String): Boolean;
{ Desc: if old association exists then fisrt restore old one , then clear.
}

//Clears or Removes an Association with or without updating desktop
Function RemoveAssociation(RegKey, Ext: String; RemoveKeyName: Boolean; UpdateSystem: Boolean): Boolean;
{ Desc: if old association exists then fisrt restore old one , then Remove.
}

Procedure CreateAssociation(Ext: String; FileName: String;
  DefaultIcon: String; KeyName: String;
  FileType: String; ShowInNew: Boolean);
{ Params Description:
  Ext: Extension Name
  FileName: Execute File Name include path(eg "d:\apps\xxx.exe")
  DefaultIcon: eg, use the first icon in execute file: "D:\APPS\xxxx.exe,0"
  KeyName: Ext Key Name, such as "JediEdit.c"
  FileType: File Type Description, such as 'C Language File'
  ShowInNew: if true then put command(Execute File Name) into 'ShellNew' register Key
             else  put into 'Shell' register key
  Desc: first try to backup old Association then CreateAssociation.
}

//Makes association
Procedure MakeAssociation(Ext: String; PgmToLinkTo: String;
  DefaultIcon: String; KeyName: String;
  TypeName: String; ShowInNew: Boolean);
{ Ext: Extension Name
  pgmToLinkTo: Execute File Name include path(eg "d:\apps\xxx.exe")
  KeyName:
  Desc: see above, this function no error check.
}

{------------Low Level Functions---------}
Function RemoveParams(Value: String): String;
Function SaveIntToRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: Integer): Boolean;
Function LoadIntFromRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: Integer): Integer;
Function SaveStrToRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: String): Boolean;
Function LoadStrFromRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: String): String;
Function SaveBoolToRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: Boolean): Boolean;
Function LoadBoolFromRegistry(MainKey: LongInt; RegistryKey, AItem: String; AValue: Boolean): Boolean;

{Deletes a key with and subkeys on win95}
Function DeleteRegKey(MainKey: LongInt; AKey: String): Boolean;

{Deletes a key with and subkeys on win95/NT}
Function NTDeleteRegKey(MainKey: LongInt; Const AKey: String): Boolean;

{Sets a stringlist with all subkeys}
Function GetRegSubTree(MainKey: LongInt; AKey, AValue: String; Const AList: TStrings): Boolean;
{ if aValue <> '' then these subkeys must include aValue string.
}

{The following methods return or set the default key values}
Procedure ChangeRegistryInt(mainKey: LongInt; AKey: String; AValue: LongInt);
Procedure ChangeRegistryStr(mainKey: LongInt; AKey: String; AValue: String);
Procedure ChangeRegistryBool(mainKey: LongInt; AKey: String; AValue: Boolean);

Function GetRegistryStr(mainKey: LongInt; AKey: String; Default: String): String;
Function GetRegistryInt(mainKey: LongInt; AKey: String; Default: Integer): Integer;
Function GetRegistryBool(MainKey: LongInt; AKey: String; Default: Boolean): Boolean;

Const
  sOldDefault = 'Old Default';

Implementation

//Set a value in the registry;

Procedure SetValInReg(RKey: HKey; KeyPath: String;
  ValName: String; NewVal: String);
Begin
  With TRegistry.Create Do Try
    RootKey := RKey;
    OpenKey(KeyPath, True);
    WriteString(ValName, NewVal);
  Finally
    Free;
  End;
End;

Procedure RegisterAllFileType(MenuName, Command: String);
{Click on a File in Explorer with right mouse key ,
uses this function you may add new menu item to popup menu
MenuName:display on the popup menu name
Command: execute command}
Begin
  SetValInReg(HKEY_CLASSES_ROOT, '*\shell\' + MenuName + '\command', '', Command);
  //  SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_FLUSH,pchar(''),pchar(''));  {update system of assocciation change}
End;

Procedure UnRegisterAllFileType(MenuName: String);
Begin
  NTDeleteRegKey(LongInt(HKEY_CLASSES_ROOT), '*\Shell\' + MenuName);
  //  SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_FLUSH,pchar(''),pchar(''));  {update system of assocciation change}
End;

Function ExtDescription(Ext: String): String;
Var
  AReg: TRegistry;
  AssocKey: String;
Begin
  Result := ''; {initialize result to empty string if exception occurrs}
  AReg := TRegistry.Create;
  Try
    AReg.RootKey := HKEY_CLASSES_ROOT;
    //Lowercase to avoid trouble
    Ext := LowerCase(Ext);
    If AReg.KeyExists(Ext) Then Begin
      AReg.OpenKey(Ext, False);
      AssocKey := AReg.ReadString('');
      AReg.CloseKey;
      If AReg.OpenKey(AssocKey, False) Then Begin
        Result := AReg.ReadString('');
        Exit;
      End;
    End;
  Finally
    AReg.Free;
  End; //try
End;

Procedure UpdateAssociationPath(Const KeyName, FileName: String);
Var
  AReg: TRegistry;
  s: String;
Begin
  AReg := TRegistry.Create;
  Try
    AReg.RootKey := HKEY_CLASSES_ROOT;
    If AReg.OpenKey(KeyName, False) Then Begin
      If AReg.OpenKey('Shell\Open\Command', False) Then Begin
        s := RemoveParams(AReg.ReadString(''));
        If UpperCase(s) <> UpperCase(FileName) Then
          AReg.WriteString('', '"' + FileName + '" "%1"');
      End;
    End;
  Finally
    AReg.Free;
  End; //try
End;

Function AssociationExists(Ext: String; Var FileName: String): String;
Var
  AReg: TRegistry;
  AssocKey: String;
Begin
  Result := ''; {initialize result to empty string if exception occurrs}
  FileName := '';
  AReg := TRegistry.Create;
  Try
    AReg.RootKey := HKEY_CLASSES_ROOT;
    //Lowercase to avoid trouble
    Ext := LowerCase(Ext);
    //Check if the key (.???) exists
    //  If Pos('.', Ext)=0 then Ext:='.'+Ext;
    If Not AReg.KeyExists(Ext) Then Begin
      Result := '';
    End
    Else Begin
      AReg.OpenKey(Ext, False);
      AssocKey := AReg.ReadString('');
      Result := AssocKey;
      AReg.CloseKey;
      If Not AReg.OpenKey(AssocKey, False) Then Begin
        Result := '';
        Exit;
      End;
      If Not AReg.OpenKey('Shell\Open\Command', False) Then Begin
        Result := AReg.ReadString('');
        Exit;
      End;
      FileName := RemoveParams(AReg.ReadString(''));
    End;
  Finally
    AReg.Free;
  End; //try
End;

//Clears or Removes an Association with or without updating desktop

Function RemoveAssociation(RegKey, Ext: String; RemoveKeyName: Boolean; UpdateSystem: Boolean): Boolean;
Begin
  If RemoveKeyName Then
    Result := DeleteAssociation(RegKey, Ext)
  Else
    Result := ClearAssociation(RegKey, Ext);
  If UpdateSystem Then
    SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, PChar(''), PChar('')); {update system of assocciation change}
End;

Function ClearAssociation(RegKey, Ext: String): Boolean;
Var
  OldKeyName: String;
Begin
  Result := False;
  If Ext = '' Then Exit; {only perform if valid}
  //  If Pos('.', Ext)=0 then Ext:='.'+FExt;
  If DoesKeyExist(RegKey) Then Begin
    OldKeyName := LoadStrFromRegistry(LongInt(HKEY_CLASSES_ROOT), RegKey, //register key
      sOldDefault, //specify the data item
      ''); //default return Value
    SetValInReg(HKEY_CLASSES_ROOT,
      Ext, { extension we want to define }
      '', { specify the default data item }
      OldKeyName); { clear or restore reference to association  }
  End;
End;

Function DeleteAssociation(RegKey, Ext: String): Boolean;
Var
  OldKeyName: String;
Begin
  Result := False; {initialize result}
  If Ext = '' Then Exit; {only perform if not empty}
  //  If Pos('.', Ext)=0 then Ext:='.'+Ext;  {make sure its a extension}
  Ext := LowerCase(Ext);
  If Not DoesKeyExist(Ext) Then Exit; {only perform if registered file extension}
  OldKeyName := GetRegistryStr(LongInt(HKEY_CLASSES_ROOT), Ext, ''); {Get the registered file extension' regKey}
  If OldKeyName <> RegKey Then Exit; {only perform if OldKeyName matches the regKey}

  OldKeyName := LoadStrFromRegistry(LongInt(HKEY_CLASSES_ROOT),
    RegKey, //register key
    sOldDefault, //specify the data item
    ''); //default return Value
  Result := NTDeleteRegKey(LongInt(HKEY_CLASSES_ROOT), Ext); {remove keys and subkeys for extension}
  If Not Result Then Exit; {error occurred get out}
  Result := NTDeleteRegKey(LongInt(HKEY_CLASSES_ROOT), RegKey); {remove keys and subkeys for association}
  If OldKeyName <> '' Then {Restore Old Default association}  Begin
    SetValInReg(HKEY_CLASSES_ROOT,
      Ext, { extension we want to define }
      '', { specify the default data item }
      OldKeyName); { restore reference to association  }
  End;
End;

Function DoesKeyExist(AKey: String): Boolean;
Var
  AReg: TRegistry;
Begin
  AReg := TRegistry.Create;
  Try
    AReg.RootKey := HKEY_CLASSES_ROOT;
    Result := AReg.OpenKey(AKey, False);
  Finally
    AReg.Free;
  End;
End;

Procedure UpdateAssociationToSystem;
Begin
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, PChar(''), PChar('')); {update system of assocciation change}
End;

Procedure CreateAssociation(Ext: String; FileName: String;
  DefaultIcon: String; KeyName: String;
  FileType: String; ShowInNew: Boolean);
Begin
  If (Ext = '') Or (KeyName = '') Then Exit;
  //  If Pos('.', Ext)=0 then Ext:='.'+Ext;
  MakeAssociation(Ext, FileName, DefaultIcon, KeyName, FileType, ShowInNew);
  SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, PChar(''), PChar('')); {update system of assocciation change}
End;

//Makes association

Procedure MakeAssociation(Ext: String; PgmToLinkTo: String;
  DefaultIcon: String; KeyName: String;
  TypeName: String; ShowInNew: Boolean);
Var
  oldKeyName: String;
Begin
  { ALL extensions must be in lowercase to avoid trouble! }
  Ext := LowerCase(Ext);
  If FileExists(PgmToLinkTo) Then Begin
    OldKeyName := LoadStrFromRegistry(LongInt(HKEY_CLASSES_ROOT),
      Ext, //register key
      '', //specify the default data item
      ''); //default return Value
    SetValInReg(HKEY_CLASSES_ROOT,
      Ext, { extension we want to define }
      '', { specify the default data item }
      KeyName); { This is the value of the default data item -
    this referances our new type to be defined  }
    If ShowInNew Then Begin
      SetValInReg(HKEY_CLASSES_ROOT,
        Ext + '\ShellNew', // you forgot to add the shellnew Almer
        'Nullfile',
        '');
      SetValInReg(HKEY_CLASSES_ROOT,
        KeyName + '\ShellNew', // you forgot to set the key shellnew Also
        '',
        'Nullfile');
    End;
    SetValInReg(HKEY_CLASSES_ROOT,
      KeyName, { this is the type we want to define }
      '', { specify the default data item }
      TypeName); { This is the value of the default data item -
    this is the English description of the file type }
    SetValInReg(HKEY_CLASSES_ROOT,
      KeyName + '\shell\open\command', { create a file...open key }
      '', { specify the default data item }
      '"' + PgmToLinkTo + '" "%1"'); { command line to open file with }
    If DefaultIcon <> '' Then
      SetValInReg(HKEY_CLASSES_ROOT,
        KeyName + '\DefaultIcon', '', DefaultIcon);
    If OldKeyName <> '' Then
      SetValInReg(HKEY_CLASSES_ROOT,
        KeyName, sOldDefault, OldKeyName);
  End {of MakeAssociation}
  Else
    ShowMessage('Error: Program not found: ' + PgmToLinkTo);