Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

266 lines (224 sloc) 6.319 kB
program AssociateFiles;
//File association extension for Simba by Nielsie95
//http://villavu.com/forum/showthread.php?t=56853
const
ExtensionsDef = 'simb,simba,sex';
var
SimbaMenu: TMenuItem;
Extensions: string;
type
TCharArray = array of Char;
function GetModuleFileName(
Module: Cardinal; FileName: TCharArray; Size: Cardinal
): Cardinal; external 'GetModuleFileNameA@kernel32 stdcall';
function RegCreateKeyEx(
Key: LongWord; lpSubKey: TCharArray{PChar}; Reserved: LongInt; lpClass: Integer;
dwOptions: LongInt; samDesired: LongWord; SecurityAttributes: Integer;
var pResult: LongWord; var dwDisposition: Integer
): LongInt; external 'RegCreateKeyExA@advapi32.dll stdcall';
function RegCloseKeyEx(
Key: LongWord
): Integer; external 'RegCloseKey@advapi32.dll stdcall';
function RegSetValueEx(
Key: LongWord; lpValueName: TCharArray{PChar}; Reserved: LongInt; dwType: LongInt;
Data: TByteArray{PByte}; cbData: LongInt
): Integer; external 'RegSetValueExA@advapi32.dll stdcall';
procedure SHChangeNotify(
EventID: Integer; Flags: Cardinal; Item1, Item2: Integer
); external 'SHChangeNotify@shell32.dll stdcall';
const
REG_OPTION_NON_VOLATILE = 0;
//KEY_ALL_ACCESS = 983130;
KEY_WRITE = 131087;
ERROR_SUCCESS = 0;
ERROR_ACCESS_DENIED = 5;
ERROR_BADKEY = 1010;
ERROR_CANTOPEN = 1011;
ERROR_CANTREAD = 1012;
ERROR_CANTWRITE = 1013;
ERROR_KEY_DELETED = 1018;
HKEY_CLASSES_ROOT = $80000000;
HKEY_CURRENT_USER = $80000001;
HKEY_LOCAL_MACHINE = $80000002;
HKEY_USERS = $80000003;
HKEY_CURRENT_CONFIG = $80000005;
REG_NONE = 0;
REG_SZ = 1;
REG_EXPAND_SZ = 2;
REG_BINARY = 3;
REG_DWORD = 4;
SHCNE_ASSOCCHANGED = $08000000;
SHCNF_IDLIST = 0;
function StringToCharArray(s: string): TCharArray;
var
i, l: Integer;
begin
l := Length(s);
SetLength(Result, l + 1);
for i := l downto 1 do
Result[i - 1] := s[i];
Result[l] := #0;
end;
function StringToByteArray(s: string): TByteArray;
var
i, l: Integer;
begin
l := Length(s);
SetLength(Result, l + 1);
for i := l downto 1 do
Result[i - 1] := Ord(s[i]);
Result[l] := 0;
end;
function SetString(Buffer: TCharArray; Len: Cardinal): string;
var
i: Integer;
begin
if (Len < 1) then
Result := ''
else
begin
SetLength(Result, Len);
for i := 0 to Len - 1 do
Result[i + 1] := Buffer[i];
end;
end;
function GetExeName: string;
var
Buffer: array of Char;
begin
SetLength(Buffer, 261);
Result := SetString(Buffer, GetModuleFileName(0, Buffer, Length(Buffer)));
end;
function RegOpenKey(KeyName: string; Root: LongWord; out Key: LongWord): Boolean;
var
s: TCharArray;
disp: Integer;
begin
Result := False;
s := StringToCharArray(KeyName); //Conversion to "PChar"
case RegCreateKeyEx(Root, s, 0, 0, REG_OPTION_NON_VOLATILE, KEY_WRITE, 0, Key, disp) of
ERROR_SUCCESS: Result := True;
ERROR_ACCESS_DENIED: WriteLn('Access denied');
ERROR_BADKEY: WriteLn('Bad key');
ERROR_CANTOPEN: WriteLn('Can''t open');
ERROR_CANTREAD: WriteLn('Can''t read');
ERROR_CANTWRITE: WriteLn('Can''t write');
ERROR_KEY_DELETED: WriteLn('Key marked for deletion');
end;
case disp of
1: WriteLn('Key "'+KeyName+'" did not exist and was created.');
2: WriteLn('Key "'+KeyName+'" existed and was simply opened without being changed.');
end;
end;
function RegCloseKey(Key: LongWord): Boolean;
begin
Result := RegCloseKeyEx(Key) = ERROR_SUCCESS;
end;
function RegCreateKey(KeyName: string; Root: LongWord): Boolean;
var
t: LongWord;
begin
if RegOpenKey(KeyName, Root, t) then
Result := RegCloseKey(t)
else
Result := False;
end;
function RegWriteString(Key: LongWord; Name, Value: string): Boolean;
var
n: TCharArray;
v: TByteArray;
begin
n := StringToCharArray(Name);
v := StringToByteArray(Value);
Result := RegSetValueEx(Key, n, 0, REG_SZ, v, Length(v)) = ERROR_SUCCESS;
end;
function AssociateExtension(Extension, ContentType, App: string): Boolean;
var
t: LongWord;
begin
Result := False;
if (Extension = '') then
Exit;
if (not RegOpenKey('.' + Extension, HKEY_CLASSES_ROOT, t)) then
Exit;
RegWriteString(t, '', 'Simba.' + Extension);
if (ContentType <> '') then
RegWriteString(t, 'Content Type', ContentType);
RegCloseKey(t);
if (App <> '') then
begin
if (not RegOpenKey('Simba.' + Extension + '\DefaultIcon', HKEY_CLASSES_ROOT, t)) then
Exit;
RegWriteString(t, '', App + ',0');
RegCloseKey(t);
if (not RegOpenKey('Simba.' + Extension + '\shell', HKEY_CLASSES_ROOT, t)) then
Exit;
RegWriteString(t, '', 'open');
RegCloseKey(t);
if (not RegOpenKey('Simba.' + Extension + '\shell\open\command', HKEY_CLASSES_ROOT, t)) then
Exit;
RegWriteString(t, '', '"' + App + '" "%1"');
RegCloseKey(t);
end;
Result := True;
end;
procedure UpdateAssociations;
var
s: string;
e: TStringArray;
i: Integer;
begin
s := GetExeName;
e := Explode(',', Extensions);
if (s <> '') and (Length(e) > 0) then
begin
for i := High(e) downto 0 do
if (not AssociateExtension(e[i], 'text', s)) then
Break;
if (i >= 0) then
WriteLn('Association failed!')
else
begin
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0);
WriteLn('Associations updated!');
end;
end;
end;
procedure OnClick(sender : TObject);
begin;
UpdateAssociations;
end;
procedure Init;
var
m: TMenuItem;
begin;
Extensions := Settings.GetKeyValueDef('Extensions', ExtensionsDef);
m := TMenuItem.Create(Simba_MainMenu);
m.Caption := '-';
Simba_MainMenu.Items.Items[4].Insert(Simba_MainMenu.Items.Items[4].Count - 2, m);
SimbaMenu := TMenuItem.Create(Simba_MainMenu);
SimbaMenu.Caption := 'Associate File Extensions';
SimbaMenu.OnClick := @OnClick;
Simba_MainMenu.Items.Items[4].Insert(Simba_MainMenu.Items.Items[4].Count - 2, SimbaMenu);
end;
procedure Free;
begin
end;
procedure Attach;
begin;
SimbaMenu.Visible := True;
end;
Procedure Detach;
begin
SimbaMenu.Visible := False;
end;
function GetName : string;
begin;
Result := 'Associate File Extensions (by Nielsie95)';
end;
function GetVersion : string;
begin;
result := '0.1';
end;
begin
end.
Jump to Line
Something went wrong with that request. Please try again.