给你一个程序！请提供mail,
主pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
Psock, StdCtrls, ScktComp,ServerThread, Buttons,
registry, Menus, ExtCtrls,Shellapi, Graphics;
const
WM_TRAYNOTIFY=WM_USER+1;//定义通知消息
type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N10: TMenuItem;
historylistbox: TListBox;
PopupMenu1: TPopupMenu;
N12: TMenuItem;
Timer1: TTimer;
Image1: TImage;
PopupMenu2: TPopupMenu;
N11: TMenuItem;
N13: TMenuItem;
N14: TMenuItem;
Memo1: TMemo;
procedure ServerSocket1GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket;
var SocketThread: TServerClientThread);
procedure ServerSocket1ThreadEnd(Sender: TObject;
Thread: TServerClientThread);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure MainMenu1Change(Sender: TObject; Source: TMenuItem;
Rebuild: Boolean);
procedure N2Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure N12Click(Sender: TObject);
procedure N9Click(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure WndProc(var Msg: TMessage); override;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure N13Click(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure N14Click(Sender: TObject);
private
public
function rigisterhttpserver:integer;
function savefile:integer;
procedure ApppendToSysTemMenu(Form:TForm;Item:String;itemid:word);
procedure registermsg(var msg: Tmsg; var handled: boolean);
function terminatestreads: integer;
end;
var
Form1: TForm1;
rootdir:string;
serverport:string;
defaultpage:string;
backdir:string;
intervaltime:string;
nd:NotifyIconData;
cache:TThreadlist;
implementation
uses Unit2, Unit3;
{$R *.DFM}
procedure TForm1.registermsg(var msg: Tmsg; var handled: boolean);
begin
if msg.message =WM_syscommand then
if msg.wparam=79 then
n9.Click;
end;
procedure TForm1.ApppendToSysTemMenu(Form:TForm;Item:String;itemid:word);
var
normalsysmenu,minimizedmenu:hmenu;
aitem:array[0..255] of char;
pitem
char;
begin
normalsysmenu:=getsystemmenu(form.handle,false);
minimizedmenu:=getsystemmenu(Application.Handle ,false);
if item='-' then
begin
appendmenu(normalsysmenu,mf_separator,0,nil);
appendmenu(minimizedmenu,mf_separator,0,nil);
end
else
begin
pitem:=strpcopy(@Aitem,item);
appendmenu(normalsysmenu,MF_STRING,ItemID,PItem);
appendmenu(minimizedmenu,MF_STRING,ItemID,PItem);
end;
end;
function Tform1.savefile:integer;
var
flname,tf:string;
f:Textfile;
test:Tstringlist;
begin
tf:=copy(backdir,length(backdir),1);
if tf='/' then
flname:=backdir+datetostr(date)+'log.txt'
else
flname:=backdir+'/'+datetostr(date)+'log.txt';
if not(FileExists(flname)) then
begin
test:=Tstringlist.Create;
test.SaveToFile(flname);
test.Free;
end;
AssignFile(F,flname);
Append(f);
flname:=self.historylistbox.Items.Text;
if flname<>'' then
Write(f,flname);
Flush(f);
CloseFile(F);
self.historylistbox.Clear;
end;
procedure TForm1.WndProc(var Msg: TMessage);
var
IconID:integer;
pt:TPOINT;
begin
if msg.Msg = WM_TRAYNOTIFY then
begin
{
在通知消息中，wParam参数为图标的uID，
lParam参数为鼠标事件的类型。
}
iconID := msg.WParam;
//获取鼠标的在屏幕上的位置
GetCursorPos(pt);
//通知消息的处理的基本框架结构如下：
case msg.lParam of
WM_LBUTTONDOWN:
begin
//鼠标左键被按下
end;
WM_RBUTTONDOWN:
begin
//鼠标右键被按下
PopupMenu2.Popup((mouse.CursorPos.x),(mouse.CursorPos.y));
end;
WM_LBUTTONUP:
begin
//释放鼠标左键
end;
WM_RBUTTONUP:
begin
//释放鼠标右键
end;
WM_MOUSEMOVE:
begin
//鼠标在图标上移动
end;
WM_LBUTTONDBLCLK:
begin
//鼠标左键双击
end;
WM_RBUTTONDBLCLK:
begin
//鼠标右键双击
end;
end; //end case
end
else//调用父类的WndProc方法处理其它消息
inherited;
end;
function TForm1.rigisterhttpserver:integer;
var
RegF:TRegistry;
tmp:string;
begin
RegF:=TRegistry.Create;
RegF.RootKey:=HKEY_LOCAL_MACHINE;
RegF.OpenKey('Software/dcs/httpserver',true);
rootdir:=RegF.ReadString('rootdir');
tmp:=copy(rootdir,length(rootdir),1);
if ((tmp='/') or (tmp='/')) then
rootdir:=copy(rootdir,1,length(rootdir)-1);
serverport:=RegF.ReadString('port');
defaultpage:=RegF.ReadString('defaultpage');
backdir:=RegF.ReadString('backdir');
intervaltime:=RegF.ReadString('intervaltime');
if ((rootdir='') or (serverport='') or (defaultpage='')) then
begin
form2.ShowModal;
end;
RegF.CloseKey;
RegF.Free;
try
if intervaltime='0' then
timer1.Enabled:=false
else
begin
timer1.Interval:=strtoint(intervaltime)*60*1000;
timer1.Enabled:=true;
end;
except
end;
end;
procedure TForm1.ServerSocket1GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket;
var SocketThread: TServerClientThread);
begin
SocketThread:=TServerThread.Create(false,ClientSocket);
cache.Add(SocketThread);
end;
procedure TForm1.ServerSocket1ThreadEnd(Sender: TObject;
Thread: TServerClientThread);
var
i:integer;
begin
with cache.LockList do
begin
for i:=0 to count-1 do
begin
if Thread=Items
then
begin
Delete(i);
exit;
end;
end;
end;
cache.UnlockList;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
Application.Initialize();
application.ShowMainForm:=false;
ShowWindow(Application.Handle, SW_HIDE);
form1.Hide;
application.Run;
end;
procedure TForm1.FormCreate(Sender: TObject);
const
title1='杜长';
begin
ApppendToSysTemMenu(Form1,'-',78);
ApppendToSysTemMenu(Form1,'关于软件',79);
Application.OnMessage:=form1.Registermsg;
form1.Caption:=title1+'胜'+' dcs-httpserver';
nd.cbSize := sizeof(NotifyIconData);
nd.Wnd := handle;
nd.uID := 0;
nd.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
nd.uCallbackMessage := WM_TRAYNOTIFY;
nd.hIcon:=image1.Picture.Icon.Handle;
StrPLCopy(nd.szTip, '杜长胜-httpServer1.0', 63);
Shell_NotifyIcon(NIM_ADD, @nd);
cache:=TThreadlist.Create;
end;
procedure TForm1.MainMenu1Change(Sender: TObject; Source: TMenuItem;
Rebuild: Boolean);
begin
if ServerSocket1.Active then
N2.Caption:='关闭服务'
else
N2.Caption:='打开服务';
end;
procedure TForm1.N2Click(Sender: TObject);
var
i:integer;
begin
if ServerSocket1.Active then
begin
terminatestreads;
ServerSocket1.Close;
self.historylistbox.Items.Append(' '+datetimetostr(now)+' 关闭服务！');
end
else
begin
try
rigisterhttpserver;
Serversocket1.Port:=strtoint(serverport);
Serversocket1.Open;
self.historylistbox.Items.Append(' '+datetimetostr(now)+' 打开服务！');
except
application.MessageBox('端口被占用','打开错误',MB_OK+MB_ICONERROR);
end;
end;
end;
procedure TForm1.N5Click(Sender: TObject);
Var
RegF:TRegistry;
begin
RegF:=TRegistry.Create;
RegF.RootKey:=HKEY_LOCAL_MACHINE;
RegF.OpenKey('SOFTWARE/dcs/httpserver',True);
form2.Edit1.Text:=RegF.ReadString('rootdir');
form2.edit2.text:=RegF.readstring('port');
form2.edit3.text:=RegF.ReadString('backdir');
form2.edit4.text:=RegF.ReadString('intervaltime');
form2.edit5.text:=RegF.ReadString('defaultpage');
RegF.CloseKey;
RegF.Free;
form2.ShowModal;
end;
procedure TForm1.N3Click(Sender: TObject);
begin
savefile;
Shell_NotifyIcon(NIM_DELETE, @nd);
terminatestreads;
self.ServerSocket1.Close;
application.Terminate;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
rigisterhttpserver;
self.OnActivate:=nil;
end;
procedure TForm1.N12Click(Sender: TObject);
begin
if MessageBox(0,Pchar('清除日志前保存么？'),'清除日志',MB_YESNO+MB_ICONQUESTION)=IDYES then
savefile
else
historylistbox.Clear;
end;
procedure TForm1.N9Click(Sender: TObject);
begin
AboutBox.showmodal;
end;
procedure TForm1.N10Click(Sender: TObject);
begin
MessageBox(self.Handle,PChar('按照设置就可以了'),'怎样操作',MB_OK);
end;
procedure TForm1.N7Click(Sender: TObject);
begin
n12.Click;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Shell_NotifyIcon(NIM_DELETE, @nd);
cache.Free;
end;
procedure TForm1.N13Click(Sender: TObject);
begin
n3.Click;
end;
procedure TForm1.N11Click(Sender: TObject);
begin
form1.WindowState:=wsNormal;
form1.Show;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
savefile;
end;
procedure TForm1.N14Click(Sender: TObject);
var
flname:string;
tf:string;
begin
tf:=copy(backdir,length(backdir),1);
if tf='/' then
flname:=backdir+datetostr(date)+'log.txt'
else
flname:=backdir+'/'+datetostr(date)+'log.txt';
if fileexists(flname) then
shellexecute(handle,'open',pchar(flname),'"','"',sw_shownormal)
else
MessageBox(self.Handle,Pchar('还没有记录日志！'),'查看日志',MB_OK);
end;
function TForm1.terminatestreads: integer;
var
i:integer;
sf:TThread;
begin
with cache.LockList do
begin
for i:=0 to count-1 do
begin
sf:=Items;
sf.Terminate;
end;
end;
cache.UnlockList;
cache.Clear;
sleep(200);
end;
end.
附pas
unit ServerThread;
interface
uses
Windows, Messages,SysUtils,Dialogs,
Classes, Graphics, Controls,ScktComp,registry;
type accepttypekind = (requestget,requestpost,requesthead);
type
TServerThread = class(TServerClientThread)
private
fSocketStream : TWinSocketStream;
requestfilename:string; //请求的文件名
fconnectionlength:integer;
function accepttype(input:string;var str:string):accepttypekind;//返回请求类型
protected
procedure sendfile(var stream:TWinSocketStream);//发送文件
public
//constructor Create(bool:boolean;socket:TServerClientWinSocket); override;
procedure ClientExecute; override;
published
{ Published declarations }
end;
procedure Register;
const maxipdata:integer=1024;
implementation
uses unit1;
function TServerThread.accepttype(input:string;var str:string):accepttypekind;
var
wz:integer;
resultstr,tmp,cutespc:string;
tbool:boolean;
begin
tmp:=trimleft(input);
wz:=pos(#13,tmp);
tmp:=copy(tmp,1,wz-1);
//传递路径
//返回类型
wz:=pos(' ',tmp);
if wz>0 then
begin
resultstr:=AnsiLowerCase(copy(tmp,1,wz-1));
tmp:=copy(tmp,wz+1,length(tmp)-wz);
end;
tbool:=false;
if pos(' ',tmp)>0 then
tbool:=true;
wz:=length(tmp);
while tbool do
begin
cutespc:=copy(tmp,wz,1);
if cutespc=' ' then
tbool:=false;
wz:=wz-1;
tmp:=copy(tmp,1,wz);
end;
str:=tmp;
if ((resultstr='GET') or (resultstr='get')) then
begin
result:=requestget;
exit;
end;
if ((resultstr='HEAD') or (resultstr='head')) then
begin
result:=requesthead;
exit;
end;
end;
procedure TServerThread.sendfile(var stream:TWinSocketStream);
var
size,i,alllen: integer;
MyFStream:Tfilestream;
head,sendfiletype,sendfilename:string;
Buffer Char;
RegF:TRegistry;
hist:string;
begin
sendfilename:=rootdir+Format('%s',[requestfilename]);
hist:=ClientSocket.LocalAddress+' '+datetimetostr(now)+' '+requestfilename;
//Synchronize(
form1.historylistbox.Items.Append(hist);
try
if DirectoryExists(sendfilename) then
begin
alllen:=length(sendfilename);
if ((copy(sendfilename,alllen,1)='/') or (copy(sendfilename,alllen,1)='/')) then
sendfilename:=sendfilename+defaultpage
else
sendfilename:=sendfilename+'/'+defaultpage;
end;
if not(FileExists(sendfilename)) then
begin
//文件或者目录不存在
//这里需要处理，比如isapi带参数
//这里就是
ClientSocket.SendText('HTTP/1.0 404 Not Found'+#13+#10+#13+#10);
exit;
end;
//获取文件类型
RegF:=TRegistry.Create;
RegF.RootKey:=HKEY_CLASSES_ROOT;
try
sendfiletype:=ExtractFileExt(sendfilename);
RegF.OpenKey(sendfiletype,False);
sendfiletype:=RegF.ReadString('Content Type');
except
End;
RegF.CloseKey;
RegF.Free;
head:=format('%s',['HTTP/1.0 200 OK'])+#13+#10;
head:=head+'Server: dcs-http-server/1.0'+#13+#10;
head:=head+'Date: Thu, 06 Dec 2001 15:08:55 GMT'+#13+#10;
MyFStream := TFileStream.Create(sendfilename,fmShareDenyNone);
size:=MyFstream.Size;
Buffer := PChar(AllocMem(Size + 1));
MyFStream.Seek(0,0);
MyFStream.Read(buffer^,Size+1);
MYFStream.Free;
if sendfiletype<>'' then //加上文件属性
head:=head+'Content-type: '+sendfiletype+#13+#10;
head:=head+'Content-length: '+inttostr(size)+#13+#10;
head:=head+#13+#10;
//ClientSocket.SendText(head);
Stream.WriteBuffer(Pchar(head)^,length(head));
alllen:=size div 8192;
i:=0;
while ((not Terminated) and (ClientSocket.Connected) and (i<alllen+1)) do
begin
if i=alllen then
Stream.WriteBuffer((buffer+i*8192)^,size-i*8192)
else
Stream.WriteBuffer((buffer+i*8192)^,8192);
i:=i+1;
end;
FreeMem(Buffer);
except
end;
end;
procedure TServerThread.ClientExecute;
var
Stream : TWinSocketStream;
Buffer Char;
buffer1: array[0 .. 1023] of Char;
size,i,alllen: integer;
MyFStream:Tfilestream;
head,rechead,rec:string;
tttype:accepttypekind;
maxreccount,reccount,pos_cl,xh_max,xh_count:integer;
begin
head:=format('%s',['HTTP/1.0 200 OK'])+#13+#10;
head:=head+'Server:dcs-file-manager-server/1.0'+#13+#10;
head:=head+'Date:Thu, 06 Dec 2001 15:08:55 GMT'+#13+#10;
try
while (not Terminated) and ClientSocket.Connected do
begin
Stream := TWinSocketStream.Create(ClientSocket, 30000);
try
FillChar(Buffer1, maxipdata, 0);
if Stream.WaitForData(20000) then
begin
if Stream.Read(Buffer1, maxipdata) = 0 then
ClientSocket.Close
else
begin
//
rechead:=Buffer1;
//create object
pos_cl:=pos('Content-length:',rechead);
rec:=copy(rechead,pos_cl+15,length(rechead)-pos_cl-14);
pos_cl:=pos(#13+#10,rec);
{rec:=copy(rec,1,pos_cl);
//rec表示返回的字节数
if rec<>'' then
begin
maxreccount:=strtoint(trim(rec));
rec:='';
xh_max:=(maxreccount+maxipdata-1) div maxipdata;
xh_count:=1;
while ((not Terminated) and (xh_count<xh_max) and (ClientSocket.Connected)) do
begin
FillChar(Buffer1,sizeof(Buffer1), 0);
if Stream.WaitForData(20000) then
begin
if Stream.Read(Buffer1,maxipdata)<>0 then
begin
form1.Memo1.lines.add(format('xh_count:%d,xh_max:%d.maxrecount:%d',[xh_count,xh_max,maxreccount]));
if xh_count=xh_max-1 then
begin
for i:=0 to (maxreccount-(xh_count-1)*maxipdata) do
rec:=rec+buffer1;
end
else
begin
rec:=rec+buffer1;
end;
end;
end;
inc(xh_count);
end;
reccount:=0;
end;
}
//end object
//form1.Memo1.Lines.Add(rec);
tttype:=accepttype(rechead,requestfilename);
case tttype of
requesthead:
begin
ClientSocket.SendText(head+#13+#10);
ClientSocket.Close;
end;
else
sendfile(stream);
end;{end case}
ClientSocket.Close;
end;
end
else
ClientSocket.Close;
finally
Stream.Free;
end;
end;
except
//HandleException;
end;
end;
procedure Register;
begin
//RegisterComponents('Samples', [TServerThread]);
end;
end.
