[转]起因源于之前忘记一个adsl的端口

虽然只有这么点东西,但我还是做了3天,老了

 

 

/** 程序的核心,一个post线程,用于提交xml数据包

*   作者:刘昆

*   最后修改日期:  2004-9-23 

*   以上代码免费,若直接引用一下代码请告知,并保留此注释

*   作为一名程序员应该有最基本的职业道德*/

unit HTTPGetThread;

interface
uses classes, SysUtils, wininet, windows;

type
  TOnProgressEvent = procedure(TotalSize, Readed: Integer) of object;

  THTTPGetThread = class(TThread)

  private
    FTAcceptTypes: string; //接收文件类型 *.*
    FTAgent: string; //浏览器名  Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02
    FTURL: string; // url
    FTFileName: string; //文件名
    FTStringResult: AnsiString;
    FTUserName: string; //用户名
    FTPassword: string; //密码
    FTPostQuery: string; //方法名,post或者get
    FTReferer: string;
    FTBinaryData: Boolean;
    FTUseCache: Boolean; //是否从缓存读数据
    FTMimeType: string; //Mime类型

    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean; //是否文件

    BytesToRead, BytesReaded: LongWord;

    FTProgress: TOnProgressEvent;
    procedure ParseURL(URL: string; var HostName, FileName: string; var portNO: integer); //取得url的主机名和文件名
    procedure UpdateProgress;
  protected
    procedure Execute; override;
  public
    procedure setResult(FResult: boolean);
    function getResult(): boolean;
    function getFileName(): string;
    function getToFile(): boolean;
    function getFileSize(): integer;
    function getStringResult(): AnsiString;
    constructor Create(aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: string; aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

  end;

implementation

{ THTTPGetThread }

constructor THTTPGetThread.Create(aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: string; aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
begin
  FreeOnTerminate := True;
  inherited Create(True);

  FTAcceptTypes := aAcceptTypes;
  FTAgent := aAgent;
  FTURL := aURL;
  FTFileName := aFileName;
  FTUserName := aUserName;
  FTPassword := aPassword;

  //FTPostQuery := aPostQuery;

  FTPostQuery := StringReplace(aPostQuery, #13#10, '', [rfReplaceAll]);

  FTReferer := aReferer;
  FTProgress := aProgress;
  FTBinaryData := aBinaryData;
  FTUseCache := aUseCache;
  FTMimeType := aMimeType;

  FTToFile := aToFile;
  Resume;
end;

procedure THTTPGetThread.Execute;
var
  hSession: hInternet; //回话句柄
  hConnect: hInternet; //连接句柄
  hRequest: hInternet; //请求句柄
  Host_Name: string; //主机名
  File_Name: string; //文件名
  port_no: integer;

  RequestMethod: PChar;
  InternetFlag: longWord;
  AcceptType: PAnsiChar;
  dwBufLen, dwIndex: longword;
  Buf: Pointer; //缓冲区
  f: file;
  Data: array[0..$400] of Char;
  TempStr: AnsiString;
  mime_Head: string;

  procedure CloseHandles;
  begin
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hSession);
  end;

begin
  inherited;
  buf := nil;
  try
    try
      ParseURL(FTURL, Host_Name, File_Name, port_no);

      if Terminated then begin
        FTResult := False;
        Exit;
      end;
     //建立会话
      hSession := InternetOpen(pchar(FTAgent), //lpszCallerName指定正在使用网络函数的应用程序
        INTERNET_OPEN_TYPE_PRECONFIG, //参数dwAccessType指定访问类型
        nil, //服务器名（lpszProxyName）。 accesstype为GATEWAY_PROXY_INTERNET_ACCESS和CERN_PROXY_ACCESS时
        nil, //NProxyPort参数用在CERN_PROXY_INTERNET_ACCESS中用来指定使用的端口数。使用INTERNET_INVALID_PORT_NUMBER相当于提供却省的端口数。
        0); //设置额外的选择。你可以使用INTERNET_FLAG_ASYNC标志去指示使用返回句句柄的将来的Internet函数将为回调函数发送状态信息，使用InternetSetStatusCallback进行此项设置

     //建立连接
      hConnect := InternetConnect(hSession, //会话句柄
        PChar(Host_Name), //指向包含Internet服务器的主机名称（如http://www.mit.edu）或IP地址（如202.102.13.141）的字符串
        port_no, //INTERNET_DEFAULT_HTTP_PORT, //是将要连结到的TCP/IP的端口号
        PChar(FTUserName), //用户名
        PChar(FTPassword), //密码
        INTERNET_SERVICE_HTTP, //协议
        0, // 可选标记，设置为INTERNET_FLAG_SECURE，表示使用SSL/PCT协议完成事务
        0); //应用程序定义的值，用来为返回的句柄标识应用程序设备场境

      if FTPostQuery = '' then RequestMethod := 'GET'
      else RequestMethod := 'POST';

      if FTUseCache then InternetFlag := 0
      else InternetFlag := INTERNET_FLAG_RELOAD;

      AcceptType := PChar('Accept: ' + FTAcceptTypes);

    //建立一个http请求句柄
      hRequest := HttpOpenRequest(hConnect, //InternetConnect返回的HTTP会话句柄
        RequestMethod, //指向在申请中使用的"动词"的字符串，如果设置为NULL，则使用"GET"
        PChar(File_Name), //指向包含动词的目标对象名称的字符串，通常是文件名称、可执行模块或搜索说明符
        'HTTP/1.0', //指向包含HTTP版本的字符串，如果为NULL，则默认为"HTTP/1.0"；
        PChar(FTReferer), //指向包含文档地址（URL）的字符串，申请的URL必须是从该文档获取的
        @AcceptType, //指向客户接收的内容的类型
        InternetFlag,
        0);
      mime_Head := 'Content-Type: ' + FTMimeType;
      if FTPostQuery = '' then
        FTResult := HttpSendRequest(hRequest, nil, 0, nil, 0)
      else
    //发送一个指定请求到httpserver
        FTResult := HttpSendRequest(hRequest,
          pchar(mime_Head), //mime 头
          length(mime_Head), //头长度
          PChar(FTPostQuery), //附加数据缓冲区，可为空
          strlen(PChar(FTPostQuery))); //附加数据缓冲区长度

      if Terminated then
      begin
      //CloseHandles;
        FTResult := False;
        Exit;
      end;

      dwIndex := 0;
      dwBufLen := 1024;
      GetMem(Buf, dwBufLen);

    //接收header信息和一个http请求
      FTResult := HttpQueryInfo(hRequest,
        HTTP_QUERY_CONTENT_LENGTH,
        Buf, //指向一个接收请求信息的缓冲区的指针
        dwBufLen, //HttpQueryInfo内容的大小
        dwIndex); //读取的字节数

      if Terminated then begin
        FTResult := False;
        Exit;
      end;

      if FTResult or not FTBinaryData then begin //如果请求
        if FTResult then
          FTFileSize := StrToInt(StrPas(Buf));

        BytesReaded := 0;

        if FTToFile then begin
          AssignFile(f, FTFileName);
          Rewrite(f, 1);
        end else FTStringResult := '';

        while True do begin
          if Terminated then begin
            FTResult := False;
            Exit;
          end;

          if not InternetReadFile(hRequest,
            @Data, //数据内容
            SizeOf(Data), //大小
            BytesToRead) //读取的字节数
            then Break
          else
            if BytesToRead = 0 then Break
            else begin
              if FTToFile then
                BlockWrite(f, Data, BytesToRead) //将读出的数据写入文件
              else begin
                TempStr := Data;
                SetLength(TempStr, BytesToRead);
                FTStringResult := FTStringResult + TempStr;
              end;

              inc(BytesReaded, BytesToRead);

              if Assigned(FTProgress) then //执行回调函数
                Synchronize(UpdateProgress);

            end;
        end;

        if FTToFile then
          FTResult := FTFileSize = Integer(BytesReaded)
        else begin
         // SetLength(FTStringResult, BytesReaded);
          FTResult := BytesReaded <> 0;
        end;

      end;
    except
    end;
  finally
    if FTToFile then CloseFile(f);

    if assigned(Buf) then FreeMem(Buf);
    CloseHandles;
  end;
end;

 

function THTTPGetThread.getFileName: string;
begin
  result := FTFileName;
end;

function THTTPGetThread.getFileSize: integer;
begin
  result := FTFileSize;
end;

function THTTPGetThread.getResult: boolean;
begin
  result := FTResult;
end;

function THTTPGetThread.getStringResult: AnsiString;
begin
  result := FTStringResult;
end;

function THTTPGetThread.getToFile: boolean;
begin
  result := FTToFile;
end;

procedure THTTPGetThread.ParseURL(URL: string; var HostName, FileName: string; var portNO: integer);
var
  i: Integer;
begin
  if Pos('http://', LowerCase(URL)) <> 0 then
    Delete(URL, 1, 7);

  i := Pos('/', URL);
  HostName := Copy(URL, 1, i);
  FileName := Copy(URL, i, Length(URL) - i + 1);

  i := pos(':', hostName);
  if i <> 0 then begin
    portNO := strtoint(copy(hostName, i + 1, length(hostName) - i - 1));
    hostName := copy(hostName, 1, i - 1);
  end else portNO := 80;

  if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then SetLength(HostName, Length(HostName) - 1);
end;

procedure THTTPGetThread.setResult(FResult: boolean);
begin
  FTResult := FResult;
end;

procedure THTTPGetThread.UpdateProgress;
begin
  FTProgress(FTFileSize, BytesReaded);
end;

end.

 

/** 主要用来做线程和界面的交互

*   作者:刘昆

*   最后修改日期:  2004-9-23 

*   以上代码免费,若直接引用一下代码请告知,并保留此注释

*   作为一名程序员应该有最基本的职业道德*/

unit MyHttpGet;

interface

uses HTTPGetThread, windows;

type
  TOnDoneFileEvent = procedure(FileName: string; FileSize: Integer) of object;
  TOnDoneStringEvent = procedure(Result: AnsiString) of object;

  THttpGet = class
  private
    F_URL: string; //目标url
    F_GetURLThread: THTTPGetThread; //取数据的线程

    F_Accept_Types: string;
    F_Agent: string;
    F_Binary_Data: Boolean;
    F_Use_Cache: Boolean; //是否读缓存
    F_File_Name: string;
    F_User_Name: string; //用户名
    F_Password: string; //密码
    F_PostQuery: string; //方法名
    F_Referer: string;
    F_Mime_Type: string;

    F_Wait_Thread: Boolean;

    FResult: Boolean;

    FProgress: TOnProgressEvent;
    FDoneFile: TOnDoneFileEvent;
    FDoneString: TOnDoneStringEvent;

    procedure ThreadDone(Sender: TObject);

  public
    constructor Create();
    destructor Destroy(); override;
    procedure getFile();
    procedure GetString();
    procedure Abort();
  published
    property WaitThread: Boolean read F_Wait_Thread write F_Wait_Thread;
    property AcceptTypes: string read F_Accept_Types write F_Accept_Types;
    property Agent: string read F_Agent write F_Agent;
    property BinaryData: Boolean read F_Binary_Data write F_Binary_Data;
    property URL: string read F_URL write F_URL;
    property UseCache: Boolean read F_Use_Cache write F_Use_Cache;
    property FileName: string read F_File_Name write F_File_Name;
    property UserName: string read F_User_Name write F_User_Name;
    property Password: string read F_Password write F_Password;
    property PostQuery: string read F_PostQuery write F_PostQuery;
    property Referer: string read F_Referer write F_Referer;
    property MimeType: string read F_Mime_Type write F_Mime_Type;

    property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
    property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
  end;

implementation

 

{ THttpGet }

procedure THttpGet.Abort;
begin
  if Assigned(F_GetURLThread) then
  begin
    F_GetURLThread.Terminate;
    F_GetURLThread.setResult(false);
  end;
end;

constructor THttpGet.Create;
begin
  F_Accept_Types := '*/*';
  F_Agent := 'Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02';
end;

destructor THttpGet.Destroy;
begin

end;

procedure THttpGet.getFile;
var
  Msg: TMsg;
begin
  if not Assigned(F_GetURLThread) then
  begin
    F_GetURLThread := THTTPGetThread.Create(F_Accept_Types,F_Mime_Type, F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, true);
    F_GetURLThread.OnTerminate := ThreadDone;
    if F_Wait_Thread then
      while Assigned(F_GetURLThread) do
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
  end
end;

procedure THttpGet.GetString;
var
  Msg: TMsg;
begin
  if not Assigned(F_GetURLThread) then
  begin
    F_GetURLThread := THTTPGetThread.Create(F_Accept_Types,F_Mime_Type,F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, False);
    F_GetURLThread.OnTerminate := ThreadDone;
    if F_Wait_Thread then
      while Assigned(F_GetURLThread) do
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
  end
end;

procedure THttpGet.ThreadDone(Sender: TObject);
begin
  FResult := F_GetURLThread.getResult;
  if FResult then
    if F_GetURLThread.getToFile then begin
      if Assigned(FDoneFile) then FDoneFile(F_GetURLThread.getFileName, F_GetURLThread.getFileSize)
    end else
      if Assigned(FDoneString) then FDoneString(F_GetURLThread.getStringResult);

    //end else if Assigned(FError) then FError(Self);
  F_GetURLThread := nil;
end;

end.

 

/** 程序主界面

*   作者:刘昆

*   最后修改日期:  2004-9-23 

*   以上代码免费,若直接引用一下代码请告知,并保留此注释

*   作为一名程序员应该有最基本的职业道德*/

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, MyHttpGet;

type
  TMain = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Label1: TLabel;
    Panel2: TPanel;
    Panel3: TPanel;
    GroupBox1: TGroupBox;
    MeSend: TMemo;
    GroupBox2: TGroupBox;
    MeReceive: TMemo;
    Button1: TButton;
    CbSave: TCheckBox;
    Edit2: TEdit;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure onGetString(Result: AnsiString);
    procedure onGetFile(FileName: string; FileSize: Integer);

  public
    { Public declarations }
  end;

var
  Main: TMain;

implementation

{$R *.dfm}

procedure TMain.Button1Click(Sender: TObject);
var hg: THttpGet;
  strs: TStrings;
  i: Integer;
begin
  hg := nil;
  strs := nil;
  try
    strs := TStringList.Create;
    hg := THttpGet.Create;
    hg.WaitThread := false;
    hg.AcceptTypes := '*.*';

    hg.Agent := 'Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02';
    hg.BinaryData := false;
    hg.URL := 'Http://' + Edit1.Text;
    hg.UseCache := false;
    hg.FileName := 'provison.xml';
    hg.UserName := '';
    hg.Password := '';

    for i := 0 to MeSend.Lines.Count - 1 do
      strs.Add(trim(MeSend.Lines[i]));

    hg.PostQuery := strs.Text;
    hg.Referer := 'Http://' + Edit1.Text; //text/plain
    hg.MimeType := Edit2.Text;
    hg.OnDoneString := onGetString;
    hg.OnDoneFile := onGetFile;

    hg.GetString;
  finally
    strs.Free;
    hg.Free;
  end;
end;

procedure TMain.onGetFile(FileName: string; FileSize: Integer);
begin

end;

procedure TMain.onGetString(Result: AnsiString);
begin
  MeReceive.Lines.Text := Result;
end;

end