Windows

Code:

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

Icon: hIcon;

IconIndex: word;

begin

IconIndex := 1;

Icon := ExtractAssociatedIcon(HInstance,

   Application.ExeName,

   IconIndex);

DrawIcon(Canvas.Handle, 10, 10, Icon);

end;

Code:

uses

{$IFDEF WIN32}

Registry; {We will get it from the registry}

{$ELSE}

IniFiles; {We will get it from the win.ini file}

{$ENDIF}

{$IFNDEF WIN32}

const

MAX_PATH = 144;

{$ENDIF}

function GetProgramAssociation(Ext: string): string;

var

{$IFDEF WIN32}

reg: TRegistry;

s: string;

{$ELSE}

WinIni: TIniFile;

WinIniFileName: array[0..MAX_PATH] of char;

s: string;

{$ENDIF}

begin

{$IFDEF WIN32}

s := '';

reg := TRegistry.Create;

reg.RootKey := HKEY_CLASSES_ROOT;

if reg.OpenKey('.' + ext + '\shell\open\command',

   false) <> false then

begin

   {The open command has been found}

   s := reg.ReadString('');

   reg.CloseKey;

end

else

begin

   {perhaps thier is a system file pointer}

   if reg.OpenKey('.' + ext,

     false) <> false then

   begin

     s := reg.ReadString('');

     reg.CloseKey;

     if s <> '' then

     begin

       {A system file pointer was found}

       if reg.OpenKey(s + '\shell\open\command',

         false) <> false then

         {The open command has been found}

         s := reg.ReadString('');

       reg.CloseKey;

     end;

   end;

end;

{Delete any command line, quotes and spaces}

if Pos('%', s) > 0 then

   Delete(s, Pos('%', s), length(s));

if ((length(s) > 0) and

   (s[1] = '"')) then

   Delete(s, 1, 1);

if ((length(s) > 0) and

   (s[length(s)] = '"')) then

   Delete(s, Length(s), 1);

while ((length(s) > 0) and

   ((s[length(s)] = #32) or

   (s[length(s)] = '"'))) do

   Delete(s, Length(s), 1);

{$ELSE}

GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));

StrCat(WinIniFileName, '\win.ini');

WinIni := TIniFile.Create(WinIniFileName);

s := WinIni.ReadString('Extensions',

   ext,

   '');

WinIni.Free;

{Delete any command line}

if Pos(' ^', s) > 0 then

   Delete(s, Pos(' ^', s), length(s));

{$ENDIF}

result := s;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(GetProgramAssociation('gif'));

end;

Code:

uses ShlObj, ActiveX, ComObj;

...

{©Drkb v.3®Vit (Vitaly Nevzorov) - Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.}

procedure CreateShortCut(ShortCutName, Parameters, FileName: string);

var ShellObject: IUnknown;

ShellLink: IShellLink;

PersistFile: IPersistFile;

FName: WideString;

begin

ShellObject := CreateComObject(CLSID_ShellLink);

ShellLink := ShellObject as IShellLink;

PersistFile := ShellObject as IPersistFile;

with ShellLink do

   begin

     SetArguments(PChar(Parameters));

     SetPath(PChar(FileName));

     SetWorkingDirectory(PChar(extractfilepath(FileName)));

     FName := ShortCutName;

     PersistFile.Save(PWChar(FName), False);

   end;

end;

Code:

program del;

uses

ShellApi;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

var

T: TSHFileOpStruct;

P: string;

begin

P := 'C:\Windows\System\EL_CONTROL.CPL';

with T do

begin

   Wnd := 0;

   wFunc := FO_DELETE;

   pFrom := Pchar(P);

   fFlags := FOF_ALLOWUNDO

end;

SHFileOperation(T);

end.

Code:

uses ShlObj, ComObj, ActiveX;

procedure CreateLink(const PathObj, PathLink, Desc, Param: string);

var

   IObject: IUnknown;

   SLink: IShellLink;

   PFile: IPersistFile;

begin

   IObject := CreateComObject(CLSID_ShellLink);

   SLink := IObject as IShellLink;

   PFile := IObject as IPersistFile;

   with SLink do begin

     SetArguments(PChar(Param));

     SetDescription(PChar(Desc));

     SetPath(PChar(PathObj));

   end;

   PFile.Save(PWChar(WideString(PathLink)), FALSE);

end;

Code:

Unit Associations;  { Subset }

Interface

Procedure RegisterFiletype( Const extension, filetype, description,

            verb: String; params: String );

Procedure RegisterFileIcon( Const filetype, iconsource: String;

                           iconindex: Cardinal );

Function FiletypeIsRegistered( Const extension, filetype: String ):

Boolean;

Implementation

Uses Windows, Classes, SysUtils, Registry;

ResourceString

eCannotCreateKey =

  'Cannot create key %s, the user account may not have the required '+

  'rights to create registry keys under HKEY_CLASSES_ROOT.';

Type

ERegistryError = Class( Exception );

{+------------------------------------------------------------

| Procedure CreateKey

|Видимость: ограничен блоком

 | Описание:

 | Это вспомогательная функция, которая использует переданный reg объект

 | для создания раздела реестра.

 | условия возникновения ошибок:

 | Если ключ не может быть создан -  сработает исключение ERegistryError

 |  

+------------------------------------------------------------}

Procedure CreateKey( reg: TRegistry; Const keyname: String );

Begin

   If not reg.OpenKey( keyname, True ) Then

     raise ERegistryError.CreateFmt( eCannotCreateKey, [keyname] );

End; { CreateKey }

{+------------------------------------------------------------

| Procedure InternalRegisterFiletype

|

| Parameters :

|   extension  : file extension, including the dot, to register

|   filetype   : string to use as key for the file extension

|   description: string to show in Explorer for files with this

|                extension. If description is empty the file

|                type will not show up in Explorers list of

|                registered associations!

|   verb       : action to register, 'open', 'edit', 'print' etc.

|                The action will turn up as entry in the files

|                context menu in Explorer.

|   serverapp  : full pathname of the executable to associate with

|                the file extension, including any command line

|                switches. Include the "%1" placeholder as well.

|                Actions like printto may require more than one

|                placeholder.

| Visibility : restricted to unit

| Description:

|   Creates the three basic registry keys for a file extension.

|   HKCR\<extension> = <filetype>

|   HKCR\<filetype>  = <description>

|   HKCR\<filetype>\shell\<verb>\command = <serverapp>

|   If the keys already exist they are overwritten!

| Error Conditions:

|   A ERegistryError exception will result if a key cannot be

|   created. Failure to create a key is usually due to insufficient

|   user rights and only a problem on NT.

| Created:  by P. Below

+------------------------------------------------------------}

Procedure InternalRegisterFiletype( Const extension, filetype,

description,

            verb, serverapp: String );

Var

   reg: TRegistry;

   keystring: String;

Begin

   reg:= TRegistry.Create;

   Try

     reg.Rootkey := HKEY_CLASSES_ROOT;

     CreateKey( reg, extension );

     reg.WriteString( '', filetype );

     reg.CloseKey;

     CreateKey( reg, filetype );

     reg.WriteString('', description );

     reg.closekey;

     keystring := Format('%s\shell\%s\command', [filetype, verb] );

     CreateKey( reg, keystring );

     reg.WriteString( '', serverapp);

     reg.CloseKey;

   Finally

     reg.free;

   End;

End; { InternalRegisterFiletype }

{+------------------------------------------------------------

[OBJECT]

| Procedure RegisterFiletype

[OBJECT]

|

| Parameters :

|   extension  : file extension, including the dot, to register

|   filetype   : string to use as key for the file extension

|   description: string to show in Explorer for files with this

|                extension. If description is empty the file

|                type will not show up in Explorers list of

|                registered associations!

|   verb       : action to register, 'open', 'edit', 'print' etc.

|                The action will turn up as entry in the files

|                context menu in Explorer.

|   params     : The command line parameters to pass to the

|                app when a file action is requested. If this

|                parameter is empty "%1" is used by default.

| Visibility : exported from unit

| Description:

|   Builds the commandline to use from the applications filename

|   and the passed params and hands the rest of the work off to

|   InternalRegisterFiletype.

| Error Conditions: none

| Created:  by P. Below

+------------------------------------------------------------}

Procedure RegisterFiletype( Const extension, filetype, description,

            verb: String; params: String );

Begin

   If Length(params) = 0 Then

     params := '"%1"';

   InternalRegisterFiletype(

     extension, filetype, description, verb,

     ParamStr(0) + ' ' + params );

End; { RegisterFiletype }

{+------------------------------------------------------------

| Procedure RegisterFileIcon

|

| Parameters :

|   filetype  : file type key name to register the icon for

|   iconsource: full pathname of the executable or ICO file

|               that contains the icon

|   iconindex : index of the icon to use, if several are containd

|               in iconsource. Counts from 0!

| Visibility : exported from unit

| Description:

|   Creates the registry keys required to tell Explorer which icon

|   to display for files of this type. RegisterFileType needs

|   to be called first to associate the filetype with an extension.

|   The registry key added is

|   HKCR\<filetype>\DefaultIcon = <iconsource>,<iconindex>

|   If the key already exists it is overwritten!

|   The icon specified should contain both large (32*32) and small

|   (16*16) versions of the icon, to optain optimal display

|    quality. If only one icon format is present Windows will

|    generate the other from it.

| Error Conditions:

|   A ERegistryError exception will result if a key cannot be

|   created. Failure to create a key is usually due to insufficient

|   user rights and only a problem on NT.

| Error Conditions: none

| Created:  by P. Below

+------------------------------------------------------------}

Procedure RegisterFileIcon( Const filetype, iconsource: String;

                           iconindex: Cardinal );

Var

   reg: TRegistry;

   keystring: String;

Begin

   reg:= TRegistry.Create;

   Try

     reg.Rootkey := HKEY_CLASSES_ROOT;

     keystring := Format( '%s\DefaultIcon',[filetype] );

     CreateKey( reg, keystring );

     reg.WriteString( '', Format( '%s,%d', [iconsource,iconindex] ));

     reg.CloseKey;

   Finally

     reg.free;

   End;

End; { RegisterFileIcon }

{+------------------------------------------------------------

[OBJECT]

| Function FiletypeIsRegistered

[OBJECT]

|

| Parameters :

|   extension  : file extension, including the dot, to search for

|   filetype   : string to use as key for the file extension

| Returns    : True if this application is registered as server

|              for the 'open' action, false otherwise.

| Visibility : exported from unit

| Description:

|   Checks if there is a registry entry for the passed extension,

|   if it is associated with the expected file type and if this

|   application is registered as server for the 'open' action.

| Error Conditions: none

| Created:  by P. Below

+------------------------------------------------------------}

Function FiletypeIsRegistered( Const extension, filetype: String ):

Boolean;

Var

   reg: TRegistry;

   keystring: String;

Begin

   Result := False;

   reg:= TRegistry.Create;

   Try

     reg.Rootkey := HKEY_CLASSES_ROOT;

     If reg.OpenKey(extension, false) Then Begin

       { Extension is registered, check filetype }

       keystring := reg.ReadString('');

       reg.Closekey;

       If CompareText( keystring, filetype) = 0 Then Begin

         { Filetype is registered for this extension, check server. }

         keystring := Format( '%s\shell\open\command',[filetype] );

         If reg.OpenKey( keystring, false ) Then Begin

           { Command key exists, but is this app the server? }

           keystring := UpperCase( reg.ReadString(''));

           reg.CloseKey;

           If Pos( UpperCase(ParamStr(0)), keystring ) = 1 Then Begin

             { Yes, server matches! }

             Result := True;

           End; { If }

         End; { If }

       End; { If }

     End; { If }

   Finally

     reg.free;

   End;

End; { FiletypeIsRegistered }

End { Unit Associations }.

Code:

uses

ShlObj,

ComObj,

ActiveX,

CommCtrl;

type

PShellLinkInfoStruct = ^TShellLinkInfoStruct;

TShellLinkInfoStruct = record

   FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char;

   FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char;

   ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char;

   FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char;

   Description: array[0..MAX_PATH] of Char;

   FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char;

   IconIndex: Integer;

   HotKey: Word;

   ShowCommand: Integer;

   FindData: TWIN32FINDDATA;

end;

procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);

var

ShellLink: IShellLink;

PersistFile: IPersistFile;

AnObj: IUnknown;

begin

// access to the two interfaces of the object

AnObj       := CreateComObject(CLSID_ShellLink);

ShellLink   := AnObj as IShellLink;

PersistFile := AnObj as IPersistFile;

// Opens the specified file and initializes an object from the file contents.

PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0);

with ShellLink do

begin

   // Retrieves the path and file name of a Shell link object.

   GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute,

     SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile),

     lpShellLinkInfoStruct^.FindData,

     SLGP_UNCPRIORITY);

   // Retrieves the description string for a Shell link object.

   GetDescription(lpShellLinkInfoStruct^.Description,

     SizeOf(lpShellLinkInfoStruct^.Description));

   // Retrieves the command-line arguments associated with a Shell link object.

   GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute,

     SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute));

   // Retrieves the name of the working directory for a Shell link object.

   GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy,

     SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy));

   // Retrieves the location (path and index) of the icon for a Shell link object.

   GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon,

     SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon),

     lpShellLinkInfoStruct^.IconIndex);

   // Retrieves the hot key for a Shell link object.

   GetHotKey(lpShellLinkInfoStruct^.HotKey);

   // Retrieves the show (SW_) command for a Shell link object.

   GetShowCmd(lpShellLinkInfoStruct^.ShowCommand);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

const

br = #13#10;

var

LinkInfo: TShellLinkInfoStruct;

s: string;

begin

FillChar(LinkInfo, SizeOf(LinkInfo), #0);

LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk';

GetLinkInfo(@LinkInfo);

with LinkInfo do

   s := FullPathAndNameOfLinkFile + br +

     FullPathAndNameOfFileToExecute + br +

     ParamStringsOfFileToExecute + br +

     FullPathAndNameOfWorkingDirectroy + br +

     Description + br +

     FullPathAndNameOfFileContiningIcon + br +

     IntToStr(IconIndex) + br +

     IntToStr(LoByte(HotKey)) + br +

     IntToStr(HiByte(HotKey)) + br +

     IntToStr(ShowCommand) + br +

     FindData.cFileName + br +

     FindData.cAlternateFileName;

Memo1.Lines.Add(s);

end;