像腾讯这样的在IE地址栏tencent://怎么搞的？ ( 积分: 100 )

像腾讯这样的在IE地址栏tencent://怎么搞的？http://,ftp://这样的。

我有代码~~

好像操作注册表就可以`~(就是在本地加一个协议解析吧)

回家找找给你~~

好，谢谢，在线等你

{*******************************************************}
{ Using URL protocol handlers in windows Demo }
{ Author by do2008 }
{ Connect Me: Mail:do2008@gmail.com OR QQ:305995625 }
{ 2006/12/07 at NN.GX }
{*******************************************************}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry,ShellAPI;
const
URL_DO2008 = 'URL:do2008 Protocol';
KEY_URL_DO2008 = 'do2008';
type
TfrmDo2008 = class(TForm)
btnUnReg: TButton;
Label1: TLabel;
btnRegister: TButton;
Label2: TLabel;
GroupBox1: TGroupBox;
Memo1: TMemo;
Label4: TLabel;
Label5: TLabel;
Button1: TButton;
procedure btnRegisterClick(Sender: TObject);
procedure btnUnRegClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Label2MouseEnter(Sender: TObject);
procedure Label2MouseLeave(Sender: TObject);
procedure Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Label2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);

private
{ Private declarations }
ShowHelp :boolean;
public
{ Public declarations }
procedure fun_CheckUrl;
procedure MyMessage(var t:TWmCopyData);message WM_COPYDATA;

end;

var
frmDo2008: TfrmDo2008;

implementation

{$R *.dfm}

{ TForm1 }

procedure TfrmDo2008.fun_CheckURL;
var
Reg: TRegistry;
bReg: Boolean;
begin

Reg := TRegistry.Create(KEY_READ);
try
Reg.RootKey := HKEY_CLASSES_ROOT;

bReg := Reg.OpenKey(KEY_URL_DO2008, False);
finally
Reg.Free;
end;

btnUnReg.Enabled := bReg;
btnRegister.Enabled := not bReg;
end;

procedure TfrmDo2008.btnRegisterClick(Sender: TObject);
var
Reg: TRegistry;
begin

Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if ( Reg.OpenKey(KEY_URL_DO2008, True) ) then
begin
Reg.WriteString('',URL_DO2008);
Reg.WriteString('@',URL_DO2008);
Reg.WriteString('Version','0.1');
Reg.WriteString('URL Protocol','');
//Reg.WriteString('MyApp','"' + ParamStr(0) + '"');

Reg.CloseKey;
end;

//[HKEY_CLASSES_ROOT/do2008/DefaultIcon]
Reg.OpenKey(KEY_URL_DO2008+'/DefaultIcon', True);
Reg.WriteString('',ParamStr(0));
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell]
Reg.OpenKey(KEY_URL_DO2008+'/Shell', True);
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell/Open]
Reg.OpenKey(KEY_URL_DO2008+'/Shell/Open', True);
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell/Open/Command]
Reg.OpenKey(KEY_URL_DO2008+'/Shell/Open/Command', True);
Reg.WriteString('',ParamStr(0) + ' "%1"');

finally
Reg.Free;
end;

fun_CheckURL;
end;

procedure TfrmDo2008.btnUnRegClick(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.DeleteKey(KEY_URL_DO2008);
finally
Reg.Free;
end;

fun_CheckURL;
end;


procedure TfrmDo2008.FormCreate(Sender: TObject);
var
i:integer;
begin
ShowHelp := false;
fun_CheckURL(); //检查协议的注册状态

for i := 1 to ParamCount do
begin
Memo1.Lines.Add(ParamStr(i));
end;
end;

procedure TfrmDo2008.Label2MouseEnter(Sender: TObject);
begin
Label2.Font.Style := [fsBold, fsUnderline];
Label2.Font.Color := clBlue;
end;

procedure TfrmDo2008.Label2MouseLeave(Sender: TObject);
begin
Label2.Font.Style := [fsBold];
Label2.Font.Color := clBlack;
end;

procedure TfrmDo2008.Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Label2.Font.Style := [fsBold, fsUnderline];
Label2.Font.Color := clBlue;
end;

procedure TfrmDo2008.Label2Click(Sender: TObject);
begin
//用shell来启动
ShellExecute(0, 'open', 'do2008://hello,the world.', nil, nil, SW_NORMAL);
end;

procedure TfrmDo2008.MyMessage(var t: TWmCopyData);
var
s:string;
begin
if ( ShowHelp ) then
begin
Memo1.Lines.Clear();
ShowHelp := false;
end;

s:=StrPas(t.CopyDataStruct^.lpData);//接受数据并显示。
Memo1.Lines.Add(s);
end;

procedure TfrmDo2008.Button1Click(Sender: TObject);
begin
Memo1.Lines.Clear();
Memo1.Lines.Add('1. Run this demo;');
Memo1.Lines.Add('2. Click "Register do2008:// Protocol" Button to Register My Protocol ');
Memo1.Lines.Add('3. OK! Run your Explorer or IE,Input "do2008://hello,the world! " at the URL addres,then press Rnter! ');
Memo1.Lines.Add('4. Now,the Message will de display at this Memo;');

Memo1.Lines.Add('');
Memo1.Lines.Add('5. Click "UnRegister do2008:// Protocol" Button to UnRegister.');
ShowHelp := true;
end;

end.

谢谢思雨，你女儿名气起好了没？

学习..思雨女儿取了什么名字啊?

有没有不让程序再启动一个的？这东西输入后程序又要再开一个！

我在线等，急啊。。。。

再启动一个什么？都没说清楚急也没用。

再说已经是另外一个问题了。

回复， 起好了，叫赖茵雨

再启动一个，你程序加上代码不允许重复运行就行了，

關注中....多多學習...

谢谢咯，哎，你没有采用我给你的名字。。

我想让他IE一按回车就显示出我输入的，如果再运行一个程序的话能读取到，但是防止重复运行了就读取不到。

老兄,抢我的生意啊~~

^_^

{*******************************************************}
{ Using URL protocol handlers in windows Demo }
{ Author by do2008 }
{ Connect Me: Mail:do2008@gmail.com OR QQ:305995625 }
{ 2006/12/07 at NN.GX }
{*******************************************************}

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry,ShellAPI;
const
URL_DO2008 = 'URL:do2008 Protocol';
KEY_URL_DO2008 = 'do2008';
type
TfrmDo2008 = class(TForm)
btnUnReg: TButton;
Label1: TLabel;
btnRegister: TButton;
Label2: TLabel;
GroupBox1: TGroupBox;
Memo1: TMemo;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Button1: TButton;
procedure btnRegisterClick(Sender: TObject);
procedure btnUnRegClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Label2MouseEnter(Sender: TObject);
procedure Label2MouseLeave(Sender: TObject);
procedure Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Label2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);

private
{ Private declarations }
ShowHelp :boolean;
public
{ Public declarations }
procedure fun_CheckUrl;
procedure MyMessage(var t:TWmCopyData);message WM_COPYDATA;

end;

var
frmDo2008: TfrmDo2008;

implementation

{$R *.dfm}

{ TForm1 }

procedure TfrmDo2008.fun_CheckURL;
var
Reg: TRegistry;
bReg: Boolean;
begin

Reg := TRegistry.Create(KEY_READ);
try
Reg.RootKey := HKEY_CLASSES_ROOT;

bReg := Reg.OpenKey(KEY_URL_DO2008, False);
finally
Reg.Free;
end;

btnUnReg.Enabled := bReg;
btnRegister.Enabled := not bReg;
end;

procedure TfrmDo2008.btnRegisterClick(Sender: TObject);
var
Reg: TRegistry;
begin

Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if ( Reg.OpenKey(KEY_URL_DO2008, True) ) then
begin
Reg.WriteString('',URL_DO2008);
Reg.WriteString('@',URL_DO2008);
Reg.WriteString('Version','0.1');
Reg.WriteString('URL Protocol','');
//Reg.WriteString('MyApp','"' + ParamStr(0) + '"');

Reg.CloseKey;
end;

//[HKEY_CLASSES_ROOT/do2008/DefaultIcon]
Reg.OpenKey(KEY_URL_DO2008+'/DefaultIcon', True);
Reg.WriteString('',ParamStr(0));
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell]
Reg.OpenKey(KEY_URL_DO2008+'/Shell', True);
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell/Open]
Reg.OpenKey(KEY_URL_DO2008+'/Shell/Open', True);
Reg.CloseKey;

//[HKEY_CLASSES_ROOT/do2008/Shell/Open/Command]
Reg.OpenKey(KEY_URL_DO2008+'/Shell/Open/Command', True);
Reg.WriteString('',ParamStr(0) + ' "%1"');

finally
Reg.Free;
end;

fun_CheckURL;
end;

procedure TfrmDo2008.btnUnRegClick(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.DeleteKey(KEY_URL_DO2008);
finally
Reg.Free;
end;

fun_CheckURL;
end;


procedure TfrmDo2008.FormCreate(Sender: TObject);
var
i:integer;
begin
ShowHelp := false;
fun_CheckURL(); //检查协议的注册状态

for i := 1 to ParamCount do
begin
Memo1.Lines.Add(ParamStr(i));
end;
end;

procedure TfrmDo2008.Label2MouseEnter(Sender: TObject);
begin
Label2.Font.Style := [fsBold, fsUnderline];
Label2.Font.Color := clBlue;
end;

procedure TfrmDo2008.Label2MouseLeave(Sender: TObject);
begin
Label2.Font.Style := [fsBold];
Label2.Font.Color := clBlack;
end;

procedure TfrmDo2008.Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Label2.Font.Style := [fsBold, fsUnderline];
Label2.Font.Color := clBlue;
end;

procedure TfrmDo2008.Label2Click(Sender: TObject);
begin
//用shell来启动
ShellExecute(0, 'open', 'do2008://http://www.mirsf51.cn', nil, nil, SW_NORMAL);
end;

procedure TfrmDo2008.MyMessage(var t: TWmCopyData);
var
s:string;
begin
if ( ShowHelp ) then
begin
Memo1.Lines.Clear();
ShowHelp := false;
end;

s:=StrPas(t.CopyDataStruct^.lpData);//接受数据并显示。
Memo1.Lines.Add(s);
end;

procedure TfrmDo2008.Button1Click(Sender: TObject);
begin
Memo1.Lines.Clear();
Memo1.Lines.Add('1. Run this demo;');
Memo1.Lines.Add('2. Click "Register do2008:// Protocol" Button to Register My Protocol ');
Memo1.Lines.Add('3. OK! Run your Explorer or IE,Input "do2008://hello,the world! " at the URL addres,then press Rnter! ');
Memo1.Lines.Add('4. Now,the Message will de display at this Memo;');

Memo1.Lines.Add('');
Memo1.Lines.Add('5. Click "UnRegister do2008:// Protocol" Button to UnRegister.');
ShowHelp := true;
end;

end.

当重复运行后，这个重复运行的程序再发送一消息数据给已运行的程序就行了啦，DEMO只是给你一个方法，总不能让人家帮你全写好吧

简单来说就是注册自己的协议，
请参考Delphi深度历险

谢谢，结帖

再次感谢各位。