Как зарегистрировать свой протокол? , Как зарегистрировать свой протокол

[BadBoyAlex]

Здравствуйте, уважаемые форумчане!
Возможно ли зарегистрировать свой протокол? Формально тот же http://, но который бы понимала только моя программа?

С EmbeddedWB кое-как реализовал это:

procedure TMainFrm.WebBrowserEvaluateNewWindow(Sender: TCustomEmbeddedWB; pszUrl, pszName, pszUrlContext, pszFeatures: PWideChar; fReplace: LongBool; dwFlags, dwUserActionTime: Cardinal; var Rezult: HRESULT);
var Prot, User, Pass, Host, Port, Path, Para, frmtdURL: string;
begin
ParseURL(pszUrl, Prot, User, Pass, Host, Port, Path, Para);
if LowerCase(Prot) = 'mmp' then
 begin
 frmtdURL:= 'http://' + Host + Path;
 //действия с файлом
 Abort;
 end;
end;

Но понимаю, что это не нормальная работа. Нужно как-то по-другому, наверное...

[Fr0sT]

В списке ассоциаций файлов погляди типы URL:*** - это то, что тебе нужно. Есть шанс, что простое добавление соответствующей записи в HKEY_CLASSES_ROOT сработает

[BadBoyAlex]

Цитата Fr0sT @ 10.05.12, 05:38

В списке ассоциаций файлов погляди типы URL:*** - это то, что тебе нужно

Да, там они "сидят".

Цитата Fr0sT @ 10.05.12, 05:38

Есть шанс, что простое добавление соответствующей записи в HKEY_CLASSES_ROOT сработае

Вот если бы ещё знать где именно)))

Будем искать. Спасибо за наводку...

Нашёл! Ещё бы знать, что из этих ключей нужно, а что - треш для программы

Сообщение отредактировано: BadBoyAlex - 10.05.12, 05:58

[Rouse_]

У нас программа умеет работать с ссылками вида slink://document/vid=100?rid=2?ps=3?pl=3

Соответственно вот так выглядит регистрация в реестре:

Windows Registry Editor Version 5.00
 
[HKEY_CLASSES_ROOT\slink]
@="URL:Grand StroyInfo Protocol"
"URL Protocol"=""
"EditFlags"=dword:00000002
 
[HKEY_CLASSES_ROOT\slink\DefaultIcon]
@="\"S:\\Grand2010\\Modules\\StroyInfo 5\\Release\\StroyInfo.exe\", 0"
 
[HKEY_CLASSES_ROOT\slink\shell]
 
[HKEY_CLASSES_ROOT\slink\shell\open]
 
[HKEY_CLASSES_ROOT\slink\shell\open\command]
@="\"S:\\Grand2010\\Modules\\StroyInfo 5\\Release\\StroyInfo.exe\" \"%1\""

При нажатии на такую ссылку запускается экземпляр программы, которому передается текст ссылки и дальше выполняется определенное дейтвие (либо выполняем действия описанные в ссылке, либо передаем ее уже запущенному экземпляру программы)

[Anatoly Podgoretsky]

Смотри ссылку в реестре PROTOCOLS

[CodeMonkey]

MSDN: http://msdn.microsoft.com/en-us/library/aa767914(VS.85).aspx

[BadBoyAlex]

Цитата Rouse_ @ 10.05.12, 08:49

либо передаем ее уже запущенному экземпляру программы)

А можно поподробнее? Просто раньше с этим не сталкивался...

[Rouse_]

Вот тебе кусок инициализирующего модуля, идея должна быть понятна:

unit uSI5.StartUp;
 
interface
 
uses
  Windows,
  Messages,
  Classes,
  SysUtils,
  Graphics,
  Forms,
  Registry,
  ShellApi;
 
type
  TInitializer = class
  private
    FLink: string;
    FMutexHandle, FMMFHandle, FWnd: THandle;
    FLinkChange: TNotifyEvent;
  protected
    procedure ActivatePreviosInstance;
    function CheckSLinkHandler: Boolean;
    procedure RegisterSLinkHandler(CheckIsAdmin: Boolean = True);
    function GetOtherInstanceHandle: THandle;
    function CheckOneInstance: Boolean;
    function NeedReinstallSLinkHandler: Boolean;
    procedure InitFileMapping;
    procedure ReleaseFileMapping;
    procedure CheckSLink;
    procedure WndProc(var Message: TMessage);
    procedure ProcessCopyData(Msg: TWMCopyData);
    procedure DoLinkChange;
...
  public
    constructor Create;
    destructor Destroy; override;
...
    procedure ResetSLink;
    property SLink: string read FLink;
    property OnLinkChange: TNotifyEvent read FLinkChange write FLinkChange;
  end;
 
var
  Initializer: TInitializer;
 
implementation
 
const
  GInfoMutexName = 'GSI Client';
  GInfoMMF = 'GSI Client MMF';
  MagicWMCopyID = $4F4B1BE4;
 
  SLinkKeyName = 'slink';
  DefaultIconKey = SLinkKeyName + '\DefaultIcon';
  CommandKey = SLinkKeyName + '\shell\open\command';
  ReinstallSLinkCommand = 'reinstallslink';
 
  function AllowSetForegroundWindow(dwProcessID: DWORD): BOOL; stdcall; external user32;
 
{ TInitilizer }
 
procedure TInitializer.ActivatePreviosInstance;
var
  OtherInstanceHandle: THandle;
  PID: Cardinal;
  CopyDataStruct: TCopyDataStruct;
begin
  OtherInstanceHandle := GetOtherInstanceHandle;
  if OtherInstanceHandle = INVALID_HANDLE_VALUE then Exit;
  GetWindowThreadProcessId(OtherInstanceHandle, PID);
  AllowSetForegroundWindow(PID);
  CopyDataStruct.dwData := MagicWMCopyID;
  CopyDataStruct.cbData := Length(FLink) * SizeOf(Char);
  if FLink <> '' then
    CopyDataStruct.lpData := @FLink[1];
  SendMessage(OtherInstanceHandle, WM_COPYDATA, 0, Integer(@CopyDataStruct));
end;
 
function TInitializer.NeedReinstallSLinkHandler: Boolean;
begin
  Result := FindCmdLineSwitch(ReinstallSLinkCommand, ['-', '/'], True);
end;
 
function TInitializer.CheckOneInstance: Boolean;
begin
  FMutexHandle := CreateMutex(nil, False, PChar(GInfoMutexName));
  Result := GetLastError <> ERROR_ALREADY_EXISTS;
  if not Result then
    CloseHandle(FMutexHandle);
end;
 
procedure TInitializer.CheckSLink;
var
  I, Len: Integer;
begin
  Len := Length(SLinkProtocolPrefix);
  for I := 1 to ParamCount do
    if LowerCase(Copy(ParamStr(I), 1, Len)) = SLinkProtocolPrefix then
    begin
      FLink := ParamStr(I);
      Break;
    end;
end;
 
function TInitializer.CheckSLinkHandler: Boolean;
begin
  Result := True;
  with TRegistry.Create do
  try
    RootKey := HKEY_CLASSES_ROOT;
    if OpenKeyReadOnly(SLinkKeyName) then
    try
      if ReadString('') <> 'URL:Grand StroyInfo Protocol' then
      begin
        Result := False;
        Exit;
      end;
      if not ValueExists('URL Protocol') then
      begin
        Result := False;
        Exit;
      end;
      if ReadString('URL Protocol') <> '' then
      begin
        Result := False;
        Exit;
      end;
    finally
      CloseKey;
    end;
    if OpenKeyReadOnly(DefaultIconKey) then
    try
      if AnsiLowerCase(ReadString('')) <> '"' + AnsiLowerCase(ParamStr(0)) + '", 0' then
      begin
        Result := False;
        Exit;
      end;
    finally
      CloseKey;
    end;
    if OpenKeyReadOnly(CommandKey) then
    try
      if AnsiLowerCase(ReadString('')) <> '"' + AnsiLowerCase(ParamStr(0)) + '" "%1"' then
      begin
        Result := False;
        Exit;
      end;
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;
 
constructor TInitializer.Create;
begin
  if NeedReinstallSLinkHandler then
  begin
    RegisterSLinkHandler(False);
    TerminateProcess(GetCurrentProcess, NO_ERROR);
  end;
 
  CheckSLink;
 
  if not CheckOneInstance then
  begin
    ActivatePreviosInstance;
    TerminateProcess(GetCurrentProcess, ERROR_SERVICE_EXISTS);
  end;
 
  if SLink = '' then
    if not CheckSLinkHandler then
      RegisterSLinkHandler;
 
  InitFileMapping;
  ShowSplash;
end;
 
destructor TInitializer.Destroy;
begin
  ReleaseFileMapping;
  CloseHandle(FMutexHandle);
  inherited;
end;
 
procedure TInitializer.DoLinkChange;
begin
  if Assigned(FLinkChange) then
    FLinkChange(Self);
end;
 
...
 
function TInitializer.GetOtherInstanceHandle: THandle;
 
  function ReadHandle: THandle;
  var
    MMFHandle: THandle;
    Data: Pointer;
  begin
    Result := INVALID_HANDLE_VALUE;
    MMFHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(GInfoMMF));
    if MMFHandle = 0 then Exit;
    try
      Data := MapViewOfFile(MMFHandle, FILE_MAP_READ, 0, 0, 0);
      if Data = nil then Exit;
      try
        Result := PInteger(Data)^;
      except
        // Другое приложение файл созадло, но еще ничего туда не записало..
        on EAccessViolation do ;
      end;
    finally
      CloseHandle(MMFHandle);
    end;
  end;
 
var
  I: Integer;
begin
  for I := 0 to 9 do
  begin
    Result := ReadHandle;
    if Result <> INVALID_HANDLE_VALUE then
      Exit;
    Sleep(100);
  end;
end;
 
...
 
procedure TInitializer.InitFileMapping;
var
  MMFData: Pointer;
begin
  FWnd := Classes.AllocateHWnd(WndProc);
  FMMFHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE,
    0, 4096, PChar(GInfoMMF));
  if FMMFHandle <> 0 then
  begin
    MMFData := MapViewOfFile(FMMFHandle, FILE_MAP_WRITE, 0, 0, 0);
    if MMFData <> nil then
    begin
      PHandle(MMFData)^ := FWnd;
      UnmapViewOfFile(MMFData);
    end;
  end;
end;
 
procedure TInitializer.ProcessCopyData(Msg: TWMCopyData);
begin
  if Msg.CopyDataStruct^.dwData <> MagicWMCopyID then Exit;
  SetLength(FLink, Msg.CopyDataStruct.cbData div SizeOf(Char));
  CopyMemory(Pointer(FLink), Msg.CopyDataStruct.lpData,
      Msg.CopyDataStruct.cbData);
  ReplyMessage(0);
  SendMessage(Application.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
  SetForegroundWindow(Application.Handle);
  DoLinkChange;
end;
 
procedure TInitializer.RegisterSLinkHandler(CheckIsAdmin: Boolean);
var
  SEI: TShellExecuteInfo;
begin
  case IsAdmin of
    csError:
      if CheckIsAdmin then Exit;
    csLimitedUser:
    begin
      if not CheckIsAdmin then Exit;
      if MessageBox(0,
        'Служебный протокол ГСИ не зарегистрирован, выполнить регистрацию сейчас?',
        'ГСИ', MB_ICONQUESTION or MB_YESNO or MB_DEFBUTTON1) = IDNO then Exit;
      SEI.cbSize := SizeOf(TShellExecuteInfo);
      SEI.lpFile := PChar(ParamStr(0));
      SEI.lpDirectory := PChar(ExtractFilePath(ParamStr(0)));
      SEI.lpVerb := PChar('runas');
      SEI.fMask := SEE_MASK_NOCLOSEPROCESS;
      SEI.nShow := SW_HIDE;
      SEI.hInstApp := HInstance;
      SEI.lpParameters := PChar('-' + ReinstallSLinkCommand);
      ShellExecuteEx(@SEI);
      Exit;
    end;
  end;
  with TRegistry.Create do
  try
    RootKey := HKEY_CLASSES_ROOT;
    if OpenKey(SLinkKeyName, True) then
    try
      WriteString('', 'URL:Grand StroyInfo Protocol');
      WriteString('URL Protocol', '');
    finally
      CloseKey;
    end;
    if OpenKey(DefaultIconKey, True) then
    try
      WriteString('', '"' + ParamStr(0) + '", 0');
    finally
      CloseKey;
    end;
    if OpenKey(CommandKey, True) then
    try
      WriteString('', '"' + ParamStr(0) + '" "%1"');
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;
 
procedure TInitializer.ReleaseFileMapping;
begin
  Classes.DeallocateHWnd(FWnd);
  CloseHandle(FMMFHandle);
end;
 
procedure TInitializer.ResetSLink;
begin
  FLink := '';
end;
 
...
 
procedure TInitializer.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_COPYDATA then
    ProcessCopyData(TWMCopyData(Message));
  inherited;
end;
 
initialization
 
  Initializer := TInitializer.Create;
 
finalization
 
  Initializer.Free;
 
end.

[Fr0sT]

Цитата Rouse_ @ 11.05.12, 14:34

ActivatePreviosInstance

PrevioUs
А так хороший код, всё понятно. Только вот великоват арсенал применяемых средств IPC: мьютекс, файлмаппинг, да еще и wm_copydata. Не проще ли было обойтись одними пайпами?

[Rouse_]

Цитата Fr0sT @ 12.05.12, 06:11

Не проще ли было обойтись одними пайпами?

Да выбор средства синхронизации по сути результата не меняет, использовал то, что проще...