博客园_闲云野鹤

Wininet请求包装类简稿

2012-03-19T10:29:00Z

unit uWnWinetClass;

interface

uses
  Windows,Messages,SysUtils,Classes,WinInet;

const
  CONST_AGENT = 'Wininet by Enli';
  BUFFER_SIZE = 4096;

type
  //定义http的请求调用方式
  //TWinWrapVerbs = (wwvGET, wwvPOST, wwvMPOST);
  //定义协议版本
  TWinHttpVersion = (wwvHttp1,wwvHttp11);
  //错误类型，没有错误为wwecNil
  TWinInetErrorCauses = (wwecNil,                             //0
                         wwecAttemptConnect,                  //1
                         wwecOpen,                            //2
                         wwecConnect,                         //3
                         wwecOpenRequest,                     //4
                         wwecConfigureRequest,                //5
                         wwecExecRequest,                     //6
                         wwecEndRequest,                      //7
                         wwecTimeOut,                         //8
                         wwecUPD,                             //9
                         wwecAbort,                           //10
                         wwecStatus,                          //11
                         wwecHeader,                          //12
                         wwecContentLength,                   //13
                         wwecContentType,                     //14
                         wwecReadFile,                        //15
                         wwecWriteFile);                      //16

  TProxyInfo = record
    FProxyType : Integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
    FProxyServer : string;
    FProxyPort : Integer;
    FProxyUserName : string;
    FProxyUserPass : string;
  end;
  TWnWinetClass = class
  private
    FNet: HINTERNET;
    FRequest: HINTERNET;
    FSession: HINTERNET;
    FRequestStream: TMemoryStream;
    FResponseStream: TMemoryStream;
    FVerb: string;
    FAbort: Boolean;
    FWininetStateChanged: Boolean;
    FTimeOut: Integer;
    FSecure: Boolean;
    FProxyInfo: TProxyInfo;
    FServerPort: Integer;
    FEncodeUrl: string;
    FErrInfo: string;
    FServerPass: string;
    FServerUser: string;
    FServerName: string;
    FProxy : string;
    FHttpHeader: string;
    FData: array [0 .. BUFFER_SIZE] of Char;
    FErrorCause: TWinInetErrorCauses;
    FHttpVersion: TWinHttpVersion;
    FStatus: integer;
    FContentType: string;
    FContentLength: Int64;
    FTotal: Int64;
    FResponseHeader: string;
    procedure SetAbort(const Value: Boolean);
    procedure FixServerInfo;
    procedure FixProxyServerInfo;
    function OpenConnection: Boolean;
    function OpenRequest: Boolean;
    function ConfigureRequest: Boolean;
    function PerformMethod: Boolean;
    function DetectProxyServer: DWORD;
    function PortToUse(APort: Integer): Integer;
    function FetchHeader(AFlags: integer): Boolean;
    function ReadResponse: Boolean; // 读取接受数据
    function ReadResponseHeader: Boolean;  //获取返回数据包头
    function FixContentLength: Boolean; // 获取接受数据的大小
    function FixContentType: Boolean; // 获取接受数据的类型
    function FixWinINetError(AError: integer): string;
    function GetHttpVersion: string;
    procedure AssignError(AError: TWinInetErrorCauses);
  public
    constructor Create;
    destructor Destroy; override;
    property Abort: Boolean read FAbort write SetAbort;
    property Response: TMemoryStream read FResponseStream;
    property HttpVersion: TWinHttpVersion read FHttpVersion write FHttpVersion;
    property ServerName: string read FServerName write FServerName;
    property ServerPort: Integer read FServerPort write FServerPort;
    property ServerUser: string read FServerUser write FServerUser;
    property ServerPass: string read FServerPass write FServerPass;
    property ProxyInfo: TProxyInfo read FProxyInfo write FProxyInfo;
    property HttpHeader: string read FHttpHeader write FHttpHeader;
    property ResponseHeader: string read FResponseHeader write FResponseHeader;
    property Status: Integer read FStatus;
    property ContentLength: Int64 read FContentLength;
    property Total: Int64 read FTotal;
    property ErrInfo: string read FErrInfo;
    property ErrorCause: TWinInetErrorCauses read FErrorCause;
    procedure CleanUp(isAll: Boolean);
    function HttpGet(isUrl:string;iiTimeout:Integer;ASecure:Boolean = False):boolean;
    function HttpPost(isUrl:string;AStream:TMemoryStream;iiTimeout:Integer;ASecure:Boolean = False):boolean;
    class function StreamToHex(AStream: TMemoryStream): string;
    class procedure HexToStream(AStream: TMemoryStream;AHex: string);
  end;

implementation

{ TWnWinetClass }

procedure TWnWinetClass.AssignError(AError: TWinInetErrorCauses);
var
  I, H: Integer;
  LTemp: string;
  LR: Cardinal;
begin
  FErrorCause := AError;
  if Length(FErrInfo) = 0 then
  begin
    LR := GetLastError;
    if (LR < 12000) or (LR < 12175) then
    begin
      H := GetModuleHandle('wininet.dll');
      SetLength(LTemp, 256);
      I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), LR, 0,
        PChar(LTemp), 256, nil);
      SetLength(LTemp, I);
      FErrInfo := 'Error '+IntTostr(LR)+':'+LTemp;
    end
    else
      FErrInfo := 'Error '+IntTostr(LR)+':'+SysErrorMessage(GetLastError);
  end;
end;

procedure TWnWinetClass.CleanUp(isAll: Boolean);
begin
  if isAll then
  begin
    if Assigned(FRequest) then
    begin
      InternetCloseHandle(FRequest);
      FRequest := nil;
    end;
    if Assigned(FSession) then
    begin
      InternetCloseHandle(FSession);
      FSession := nil;
    end;
    if Assigned(FNet) then
    begin
      InternetCloseHandle(FNet);
      FNet := nil;
    end;
  end;
  //FResponse.Clear;
  SetLength(FProxy,0);
end;

function TWnWinetClass.ConfigureRequest: Boolean;
  function SetUPD(AOption: DWORD; AUPD: PChar): Boolean;
  begin
    Result := (Length(AUPD) = 0) or InternetSetOption
      (FRequest, AOption, AUPD, Length(AUPD));
  end;

begin
  Result := False;
  if FAbort then
    Exit;
  // 设置HTTP头
  {if FFileSize > 0 then
  begin
    if Length(FHttpHeader) > 0 then
      FHttpHeader := FHttpHeader + #13#10'Range: bytes=' + IntTostr(FFileSize)
        + '-'#13#10
    else
      FHttpHeader := 'Range: bytes=' + IntTostr(FFileSize) + '-'#13#10;
  end;}
  if Length(FHttpHeader) > 0 then
  begin
    Result := HttpAddRequestHeaders(FRequest, PWideChar(FHttpHeader), Cardinal
        (-1), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);

    if not Result then
    begin
      AssignError(wwecConfigureRequest);
      Exit;
    end;
  end;
  // 设置超时
  if (FTimeOut < 1) or (FTimeOut > 999) then
    FTimeOut := 30;
  FTimeOut := FTimeOut * 1000;
  Result := InternetSetOption(FNet, INTERNET_OPTION_CONNECT_TIMEOUT, @FTimeOut,
    SizeOf(integer)) and InternetSetOption
    (FNet, INTERNET_OPTION_RECEIVE_TIMEOUT, @FTimeOut, SizeOf(integer))
    and InternetSetOption(FNet, INTERNET_OPTION_SEND_TIMEOUT, @FTimeOut, SizeOf
      (integer));

  if not(Result) then
  begin
    AssignError(wwecTimeOut);
    Exit;
  end;
  // 设置代理用户密码，访问用户密码
  if SetUPD(INTERNET_OPTION_PROXY_USERNAME, PChar(FProxyInfo.FProxyUserName))
    and SetUPD(INTERNET_OPTION_PROXY_PASSWORD, PChar(FProxyInfo.FProxyUserPass)
    ) and SetUPD(INTERNET_OPTION_USERNAME, PChar(FServerPass)) and SetUPD
    (INTERNET_OPTION_PASSWORD, PChar(FServerUser)) then
  else
    AssignError(wwecUPD);

end;

constructor TWnWinetClass.Create;
begin
  inherited;
  FResponseStream := TMemoryStream.Create;
  FRequest := nil;
  FSession := nil;
  FRequestStream := nil;
  FNet := nil;
  FAbort := False;
  FSecure := False;
  FWininetStateChanged := False;
  SetLength(FEncodeUrl,0);
  SetLength(FErrInfo,0);
  SetLength(FServerUser,0);
  SetLength(FServerPass,0);
  SetLength(FProxy,0);
  FVerb := 'GET';

end;

destructor TWnWinetClass.Destroy;
begin
  FResponseStream.Free;
  inherited;
end;

function TWnWinetClass.DetectProxyServer: DWORD;
begin
   //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
  //Result:
  //INTERNET_OPEN_TYPE_PRECONFIG                   0
  //INTERNET_OPEN_TYPE_DIRECT                      1
  //INTERNET_OPEN_TYPE_PROXY                       3
  //INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY 4
  with FProxyInfo do
  case (FProxyType-1) of
    0: Result := INTERNET_OPEN_TYPE_DIRECT;
    1:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('socks=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
    2:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('socks5=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
    3:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
  else
      Result := INTERNET_OPEN_TYPE_PRECONFIG;
  end;
end;

function TWnWinetClass.FetchHeader(AFlags: integer): Boolean;
var
  BufLen, Index: DWORD;
begin
  Result := False;
  if FAbort then Exit;
  Index := 0;
  BufLen := BUFFER_SIZE;
  FillChar(FData, BufLen, 0);
  Result := HttpQueryInfo(FRequest, AFlags, @FData, BufLen, Index);
end;

function TWnWinetClass.FixContentLength: Boolean;
var
  LTemp: string;
begin
  Result := False;
  if FAbort then Exit;
  Result := FetchHeader(HTTP_QUERY_CONTENT_LENGTH);
  LTemp := FData;
  if Result then
    FContentLength := StrToInt64Def(LTemp, 0)
  else
    AssignError(wwecContentLength);
end;

function TWnWinetClass.FixContentType: Boolean;
begin
  Result := False;
  if FAbort then Exit;
  Result := FetchHeader(HTTP_QUERY_CONTENT_TYPE);
  if Result then
    FContentType := FData
  else
    AssignError(wwecContentType);
end;

procedure TWnWinetClass.FixProxyServerInfo;
var
  ls1ServerName, lsPort: string;
  liLoc: Integer;
begin
  ls1ServerName := LowerCase(FServerName);
  liLoc := Pos(':', ls1ServerName);
  if liLoc = 0 then Exit;
  lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
  FServerName := PChar(Copy(ls1ServerName, 1, liLoc - 1));
  FServerPort := StrToIntDef(lsPort,FServerPort);
end;

procedure TWnWinetClass.FixServerInfo;
var
  ls1ServerName, lsPort: string;
  liLoc: Integer;
begin
  if FProxyInfo.FProxyType = 0 then Exit;
  ls1ServerName := LowerCase(FProxyInfo.FProxyServer);
  liLoc := Pos(':', ls1ServerName);
  if liLoc = 0 then Exit;
  lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
  FProxyInfo.FProxyServer := PChar(Copy(ls1ServerName, 1, liLoc - 1));
  FProxyInfo.FProxyPort := StrToIntDef(lsPort,FProxyInfo.FProxyPort);
end;

function TWnWinetClass.FixWinINetError(AError: integer): string;
begin
  //Result := 'Http Status: ' + IntTostr(AError);
  if FetchHeader(HTTP_QUERY_STATUS_TEXT) then
    Result := FData
  //if not Result then
  else
  begin
    AssignError(wwecStatus);
    Exit;
  end;
end;

function TWnWinetClass.GetHttpVersion: string;
begin
  if FHttpVersion = wwvHttp1 then
    Result := 'HTTP/1.0'
  else
    Result := 'HTTP/1.1';
end;

class procedure TWnWinetClass.HexToStream(AStream: TMemoryStream;AHex: string);
var
  I,iLen: Integer;
  LTemp: string;
  LB : Byte;
begin
  iLen := Length(AHex);
  if (iLen mod 3) <> 0 then
  begin
    Assert(False,'hex字符串错误');
    Exit;
  end;
  for I := 0 to (iLen div 3) - 1 do
  begin
    LTemp := Copy(AHex,I*3+1,2);
    LB := StrToIntDef('$'+LTemp,0);
    AStream.WriteBuffer(Lb,1);
    //Assert(Pos(IntToStr(LB),LTemp)=0,'asdf');
  end;

end;

function TWnWinetClass.HttpGet(isUrl: string; iiTimeout: integer;
  ASecure: Boolean): boolean;
begin
  FVerb := 'GET';
  FRequest := nil;
  FRequestStream := nil;
  SetLastError(0);
  FErrInfo := '';
  FErrorCause := wwecNil;
  Result := False;
  FEncodeUrl := isUrl;
  FTimeOut := iiTimeout;
  FSecure := ASecure;
  FixServerInfo;
  FixProxyServerInfo;
  Result := OpenConnection
  and OpenRequest
  and ConfigureRequest
  and PerformMethod;
  CleanUp(True);
end;

function TWnWinetClass.HttpPost(isUrl: string; AStream: TMemoryStream;
  iiTimeout: Integer; ASecure: Boolean): boolean;
begin
  FVerb := 'POST';
  FRequestStream := AStream;
  SetLastError(0);
  FErrInfo := '';
  FErrorCause := wwecNil;
  Result := False;
  FEncodeUrl := isUrl;
  FTimeOut := iiTimeout;
  FSecure := ASecure;
  FixServerInfo;
  FixProxyServerInfo;
  Result := OpenConnection
  and OpenRequest
  and ConfigureRequest
  and PerformMethod;
  CleanUp(True);
end;

function TWnWinetClass.OpenConnection: Boolean;
var
  LProxyType: DWORD;

  function WW_AttemptConnect: Boolean;
  begin
    Result := (CompareText(FServerName, 'localhost') = 0) or
      (InternetAttemptConnect(0) = ERROR_SUCCESS);
    if not (Result) then AssignError(wwecAttemptConnect);
  end;

  procedure CancelMaxConnectLimite();
  var
    liPerServer1, liPerServer2: Integer;
  begin
    try
      liPerServer1 := 5;
      liPerServer2 := 10;
      //INTERNET_OPTION_MAX_CONNS_PER_SERVER  73
      InternetSetOption(nil, 73, @liPerServer1, SizeOf(Integer));
      //INTERNET_OPTION_MAX_CONNS_PER_1_0_SERVER  74
      InternetSetOption(nil, 74, @liPerServer2, SizeOf(Integer));
    except
    end;
  end;

  function WW_InternetOpen: Boolean;
  var
    ltInfo: INTERNET_CONNECTED_INFO;
  begin
    FNet := InternetOpen(PChar(CONST_AGENT), LProxyType, PChar(FProxy), nil, 0);

    Result := (FNet <> nil);
    if Result then begin
      try
        if not FWininetStateChanged then begin
          //INTERNET_OPTION_CONNECTED_STATE  50
          //取消IE的脱机状态
          ltInfo.dwConnectedState := INTERNET_STATE_CONNECTED;
          ltInfo.dwFlags := 0;          // ISO_FORCE_DISCONNECTED;
          InterNetSetOption(FNet, INTERNET_OPTION_CONNECTED_STATE, @ltInfo, SizeOf(ltInfo));
        end;
      except
      end;
      //InternetSetStatusCallBack(FNet, @StatusCallBack);

      //INTERNET_OPTION_HTTP_DECODING
      if InternetSetOption(FNet, 65, @Result, 1) then begin
        Beep;
      end;
    end else begin
      AssignError(wwecOpen);
    end;
  end;

  function WW_InternetConnect: Boolean;
  var
    context: dword;
  begin
    //同步通讯设置
    context := 0;
    //异步通讯需要设置特定值
    //FCallBackContext.CallbackID := 0;
    //context:=dword(@FCallBackContext);
    FSession := InternetConnect(FNet, PChar(FServerName),
        PortToUse(FServerPort), '', '', INTERNET_SERVICE_HTTP, 0, context);
    Result := (FSession <> nil);
    if not (Result) then AssignError(wwecConnect);
  end;

begin
  Result := False;
  if FAbort then Exit;
  if WW_AttemptConnect then
  begin
    LProxyType := DetectProxyServer;
    SetLastError(0);
    if not FWininetStateChanged then CancelMaxConnectLimite();
    Result := WW_InternetOpen and WW_InternetConnect;
    FWininetStateChanged := True;
  end;
end;

function TWnWinetClass.OpenRequest: Boolean;
var
  context, ATimeOut, dwFlags: DWORD;
begin
  Result := False;
  if FAbort then
    Exit;
  context := 0;
  if FSecure then
  begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
        (GetHttpVersion), nil, nil,
      INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_SECURE or
        SECURITY_FLAG_IGNORE_UNKNOWN_CA or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
        or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID, context);
    ATimeOut := 0;
    dwFlags := 0;

    if (FRequest <> nil) and (not InternetQueryOption(FRequest,
        INTERNET_OPTION_SECURITY_FLAGS, Pointer(@ATimeOut), dwFlags)) then
    begin
      GetLastError;
    end;
  end
  else
  begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
        (getHttpVersion), nil, nil, { Ord(FSecure) * INTERNET_FLAG_SECURE or }
      INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD or
        INTERNET_FLAG_KEEP_CONNECTION, context);
  end;
  Result := (FRequest <> nil);
  if not(Result) then
    AssignError(wwecOpenRequest);
end;

function TWnWinetClass.PerformMethod: Boolean;
var
  ATimeOut, dwFlags: DWORD;
  // LErr: Cardinal;
begin
  Result := False;
  if FAbort then Exit;
  if Assigned(FRequestStream) and (FRequestStream.Size > 0) then
    Result := HTTPSendRequest(FRequest, nil, 0, FRequestStream.Memory, FRequestStream.Size)
  else
    Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
  // Result := HTTPSendRequest(FRequest, D_C_T, D_C_T_S, nil, 0);
  if not(Result) then
  begin
    if GetLastError = ERROR_INTERNET_INVALID_CA then // WinInet 无效证书颁发机构错误
    begin
      ATimeOut := 0;
      dwFlags := 0;
      InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, Pointer
          (@ATimeOut), dwFlags);
      dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
      InternetSetOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags,
        SizeOf(integer));
      Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
    end
    else
    begin
      AssignError(wwecExecRequest);
      Exit;
    end;
  end;

  Result := ReadResponseHeader
    and FixContentLength and FixContentType and ReadResponse;

end;

function TWnWinetClass.PortToUse(APort: Integer): Integer;
begin
  if APort > 0 then
    Result := APort
  else
    if FSecure then
      Result := INTERNET_DEFAULT_HTTPS_PORT
    else
      Result := INTERNET_DEFAULT_HTTP_PORT;
end;

function TWnWinetClass.ReadResponse: Boolean;
var
  ASize, ARead: DWORD;
  ABuffer: Pointer;
begin
  Result := False;
  if FAbort then Exit;
  FResponseStream.Clear;
  ASize := BUFFER_SIZE;
  FTotal := 0;
  ABuffer := AllocMem(ASize);
  try
    // HookDataReadSized;
    repeat
      Result := InternetReadFile(FRequest, ABuffer, ASize, ARead);
      if not Result then
      begin
        AssignError(wwecReadFile);
        Break;
      end;
      if (ARead > 0) then
      begin
        FResponseStream.WriteBuffer(ABuffer^, ARead);
        Inc(FTotal, ARead);
        //FTotal := ARead;
        //HookDataReadSized;
      end;
    until ((ARead = 0) or FAbort);
    FResponseStream.Seek(0,0);
  finally
    FreeMem(ABuffer, 0);
  end;
end;

function TWnWinetClass.ReadResponseHeader: Boolean;
begin
  Result := False;
  if FAbort then Exit;
  Result := FetchHeader(HTTP_QUERY_STATUS_CODE);
  if not Result then
  begin
    AssignError(wwecStatus);
    Exit;
  end;
  FStatus := StrToIntDef(FData, -1);
  if FAbort then Exit;
  Result := FetchHeader(HTTP_QUERY_RAW_HEADERS_CRLF);
  if Result then
    FResponseHeader := FData
  else
    AssignError(wwecHeader);
end;

procedure TWnWinetClass.SetAbort(const Value: Boolean);
begin
  FAbort := Value;
end;

class function TWnWinetClass.StreamToHex(AStream: TMemoryStream): string;
var
  I: Integer;
  Lb: Byte;
begin
  Result := '';
  AStream.Seek(0,0);
  for I := 1 to AStream.Size do
  begin
    AStream.ReadBuffer(LB,1);
    Result := Result + IntToHex(Ord(Lb),2)+ ' ';
    //if (I mod ALen) = 0 then
    //  Result := Result + #13#10;
  end;

end;

end.

本文链接

自备工具库

2012-02-23T02:07:00Z

http://115.com/file/e7fpe14u# skytest.rar
http://115.com/file/cl317w1j# 网络抓包工具.exe
http://115.com/file/bhgkqe5n# 全产品系列下载.exe

http://115.com/file/e7ft6alf# Speed.rar

本文链接

多屏开发的备忘

2012-01-31T06:27:00Z

1. dll里面的form显示位置问题

需要显示在主程序窗口的屏幕上，可以用下面的方法放到 TForm里面的FormActivate事件里面

var
  HM: HMonitor;
  I: Integer;
  LRect: TRect;
Begin
{$IFDEF STATIC_ADDIN}
  HM := MonitorFromWindow(FContext.MasterPageHandle, MONITOR_DEFAULTTONEAREST);
  if HM > 0 then
  begin
    for I := 0 to Screen.MonitorCount - 1 do
    if Screen.Monitors[I].Handle = HM then
    begin
      LRect := Screen.Monitors[I].WorkareaRect;
      SetBounds(LRect.Left + ((RectWidth(LRect) - Width) div 2),
        LRect.Top + ((RectHeight(LRect) - Height) div 2), Width, Height);
      Break;
    end;
  end;
{$ENDIF}
end;

也可以直接跟着主程序的窗体走,直接在Formshow里面加

Left := FContext.MainForm.Left;
Top := FContext.MainForm.Top;

本文链接

界面方面的备忘

2011-11-08T06:13:00Z

1. 透明panel

unit uWnTransparentPanel;

interface

uses
  Windows,Classes,StdCtrls,ExtCtrls,Messages,Forms;

type
  TWnTransparentPanel = class(TPanel)
  private
    FTransparentPercent: Integer;
    procedure SetTransparentPercent(const Value: Integer);
  protected
    procedure WMPaint(var message : TMessage); message WM_Paint;
  public
    procedure StepShow(const ALeft,ATop,HStet,VStep:Integer);
  published
    property TransparentPercent: Integer read FTransparentPercent write SetTransparentPercent;
  end;

implementation

{ TWnTransparentPanel }

procedure TWnTransparentPanel.SetTransparentPercent(const Value: Integer);
begin
  FTransparentPercent := Value;
end;

procedure TWnTransparentPanel.StepShow(const ALeft, ATop,HStet, VStep: Integer);
var
  I: Integer;
begin
  Visible := True;
  Left := ALeft;
  Top := ATop+VStep*10  ;
  for I := 0 to 9 do
  begin
    Top := ATop +(9-I)*VStep;
    Self.Parent.Update;
    Self.Repaint;
    Sleep(100);
    Application.HandleMessage;
  end;
end;

procedure TWnTransparentPanel.WMPaint(var message: TMessage);
  procedure AlphaBlendTabControl;
  var
  MemBitmap, OldBitmap: HBITMAP;
  BF: BLENDFUNCTION;
  MemDC, DC: HDC;
  begin
    if (Parent = nil) or not Parent.HandleAllocated then
    Exit;
    DC := GetDC(0);
    MemBitmap := CreateCompatibleBitmap(DC, Parent.Width, Parent.Height);
    ReleaseDC(0, DC);
    MemDC := CreateCompatibleDC(0);
    OldBitmap := SelectObject(MemDC, MemBitmap);
    try
      Parent.Perform(WM_ERASEBKGND, MemDC, MemDC);
      Parent.Perform(WM_PAINT, MemDC, 0);

      BF.SourceConstantAlpha := TransparentPercent;
      BF.AlphaFormat := 0;
      BF.BlendOp := AC_SRC_OVER;
      BF.BlendFlags := 0;
      Windows.AlphaBlend(Canvas.Handle, 0, 0, Width, Height, MemDC, Left, Top, Width, Height, BF);
    finally
      SelectObject(MemDC, OldBitmap);
      DeleteDC(MemDC);
      DeleteObject(MemBitmap);
    end;
  end;
begin
  inherited;
  AlphaBlendTabControl;
end;

end.

2. 设计的时候，panel可以用Anchors = [akLeft, akTop, akRight, akBottom] 加上Align = alCustom达到自动预留边框的目的，就可以避免panel用Align = alClient的时候panel贴边的问题

3. Grid载入数据的时候界面频刷的问题，主要是要Grid paint之初就要设定好高宽，而不是边画边设高宽

本文链接

rc资源文件的中英文应用备忘

2011-10-27T11:20:00Z

准备好RC文件，例如Quarter.rc：

stringtable
begin
1000, "29"

2000, "第一季度"
2001, "第二季度"
2002, "第三季度"
2003, "第四季度"
2004, "一季报"
2005, "中报"
2006, "三季报"
2007, "年报"
2008, "报告期"
2009, "从"
2010, "到"
2011, "或"
2012, "时间"
2013, "常用时间查询"
2014, "自定义年度查询"
2015, "自定义时间查询"
2016, "筛选条件"
2017, "全部资料"
2018, "请选择时间范围"
2019, "开始时间:"
2020, "结束时间:"
2021, "确认"
2022, "放弃"
2023, "年到"
2024, "年"
2025, "一季"
2026, "中报"
2027, "三季"
2028, "年报"

3000, "Quarter 1"
3001, "Quarter 2"
3002, "Quarter 3"
3003, "Quarter 4"
3004, "Q1 Report"
3005, "Mid-Year Report"
3006, "Q3 Report"
3007, "Annualreport"
3008, "ReportDate"
3009, "From"
3010, "To"
3011, "Or"
3012, "Date"
3013, "Common Time Span"
3014, "User-Defined Year"
3015, "User-Defined Time Span"
3016, "Select by"
3017, "All Related Data"
3018, "Select Time Period"
3019, "Begin Time:"
3020, "End Time:"
3021, "OK"
3022, "Cancel"
3023, "To"
3024, ""
3025, "Q1"
3026, "Q2"
3027, "Q3"
3028, "Q4"

End

用此RC文件编译成res文件，然后在代码中加上 {$R Quarter.res｝

从RC编译成RES文件有2个方法

1. 直接添加到工程中，build就可以了

2. 用命令brcc32 FileName.rc 编译

本文链接

Wininet下载类初稿

2011-10-19T01:27:00Z

unit uWnDownClass;

interface

uses
Windows,Messages,SysUtils,Classes,WinInet;

const
WM_HTTPCOMM_PROGRESS = WM_USER + 1700;
InnerAgent = 'Mozilla/4.0 (compatible; MSIE 6.0; Win32)';
HttpVersion = 'HTTP/1.1';
D_C_T = 'Content-Type:application/x-www-form-urlencoded';
D_C_T_S = Length(D_C_T);
BUFFER_SIZE = 4096;

type
//错误类型，没有错误为wwecNil
TWinInetErrorCauses = (wwecNil,                             //0
                         wwecAttemptConnect,                  //1
                         wwecOpen,                            //2
                         wwecConnect,                         //3
                         wwecOpenRequest,                     //4
                         wwecConfigureRequest,                //5
                         wwecExecRequest,                     //6
                         wwecEndRequest,                      //7
                         wwecTimeOut,                         //8
                         wwecUPD,                             //9
                         wwecAbort,                           //10
                         wwecStatus,                          //11
                         wwecContentLength,                   //12
                         wwecContentType,                     //13
                         wwecReadFile,                        //14
                         wwecWriteFile);                      //15

TProxyInfo = record
public
    FProxyType : integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
    FProxyServer : String;
    FProxyPort : integer;
    FProxyUserName : String;
    FProxyUserPass : String;
end;
TOnDownloadProgress = procedure(const ASize,ATotal: Int64) of object;
TWnDownClass = class
private
    FAbort: Boolean;
    //FhNotify: HWND;
    FResponse: TMemoryStream;
    //FKeepConnected: Boolean;
    FNet: HINTERNET;
    FRequest: HINTERNET;
    FSession: HINTERNET;
    FProxyInfo: TProxyInfo;
    FProxy: string;
    FServerPort: integer;
    FServerName: string;
    FEncodeUrl: string;
    FVerb: string;
    FHttpHeader: string;
    //FpUserData: Pointer;
    FSecure: Boolean;
    FTimeOut: Integer;
    FErrorCause: TWinInetErrorCauses;
    FWininetStateChanged: Boolean;
    FErrInfo: string;
    FServerPass: string;
    FServerUser: string;
    FData: array[0..BUFFER_SIZE] of Char;
    FStatus: Integer;
    FContentType: string;
    FContentLength: Int64;
    FTotal: Int64;
    FFileSize: Int64;
    FOnDownloadProgress: TOnDownloadProgress;
    procedure SetAbort(const Value: Boolean);
    procedure FixServerInfo;
    procedure FixProxyServerInfo;
    function OpenConnection: Boolean;
    function OpenRequest: Boolean;
    function ConfigureRequest: Boolean;
    function PerformGet: Boolean;
    procedure AssignError(AError: TWinInetErrorCauses);

    function DetectProxyServer: DWORD;
    function PortToUse(APort: Integer): Integer;
    function FetchHeader(AFlags: Integer): Boolean;
    function FixContentLength: Boolean; //获取接受数据的大小
    function FixContentType: Boolean; //获取接受数据的类型
    function ReadResponse: Boolean;    //读取接受数据
    function FixWinINetError(AError: Integer): string;
    procedure HookDataReadSized;
    procedure SetOnDownloadProgress(const Value: TOnDownloadProgress);
public
    constructor Create;
    destructor Destroy;override;
    property Abort: Boolean read FAbort write SetAbort;
    //property hNotify:HWND read FhNotify write FhNotify;
    property Response: TMemoryStream read FResponse;
    property ServerName: string read FServerName write FServerName;
    property ServerPort: integer read FServerPort write FServerPort;
    property ServerUser: string read FServerUser write FServerUser;
    property ServerPass: string read FServerPass write FServerPass;
    property ProxyInfo: TProxyInfo read FProxyInfo write FProxyInfo;
    property HttpHeader: string read FHttpHeader write FHttpHeader;
    property Status: Integer read FStatus;
    property ContentLength: Int64 read FContentLength;
    property ContentType: string read FContentType;
    property FileSize: Int64 read FFileSize write FFileSize;
    property ErrInfo: string read FErrInfo;
    property ErrorCause: TWinInetErrorCauses read FErrorCause;
    property OnDownloadProgress: TOnDownloadProgress read FOnDownloadProgress write SetOnDownloadProgress;
    procedure CleanUp(isAll: Boolean);
    function HttpGet(isUrl:string;iiTimeout:integer;ASecure:Boolean = False):boolean;
end;

implementation

uses
HTTPApp;

//HTTP通讯过程中的状态回调函数
procedure StatusCallback(ASession: hInternet; AContext, AIS: DWord; AInfo:
Pointer; ASIN: DWord); stdcall;
//var
// AReason: TWinInetCallBackReason;
// lpHostContext: PInternetCallbackContext;
begin
{ TODO : 回调函数 }
{case AIS of
    INTERNET_STATUS_RESOLVING_NAME: AReason := wwcbrResolving;
    INTERNET_STATUS_NAME_RESOLVED: AReason := wwcbrResolved;
    INTERNET_STATUS_CONNECTING_TO_SERVER: AReason := wwcbrConnecting;
    INTERNET_STATUS_CONNECTED_TO_SERVER: AReason := wwcbrConnected;
    INTERNET_STATUS_SENDING_REQUEST: AReason := wwcbrWriting;
    INTERNET_STATUS_REQUEST_SENT: AReason := wwcbrWritten;
    INTERNET_STATUS_RECEIVING_RESPONSE: AReason := wwcbrReading;
    INTERNET_STATUS_RESPONSE_RECEIVED: AReason := wwcbrRead;
    INTERNET_STATUS_CLOSING_CONNECTION: AReason := wwcbrClosing;
    INTERNET_STATUS_CONNECTION_CLOSED: AReason := wwcbrClosed;
else Exit;
end;
lpHostContext := PInternetCallbackContext(AContext);
if Assigned(lpHostContext^.OnSelfCallBack) then begin
    lpHostContext^.OnSelfCallBack(AReason);
end;
if Assigned(lpHostContext^.OnCallBack) then begin
    lpHostContext^.OnCallBack(AReason);
end; }

end;

{ TWnDownClass }

procedure TWnDownClass.AssignError(AError: TWinInetErrorCauses);
var
I, H: Integer;
LTemp: string;
LR: Cardinal;
begin
FErrorCause := AError;
if Length(FErrInfo) = 0 then
begin
    LR := GetLastError;
    if (LR < 12000) or (LR < 12175) then
    begin
      H := GetModuleHandle('wininet.dll');
      SetLength(LTemp, 256);
      I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), LR, 0,
        PChar(LTemp), 256, nil);
      SetLength(LTemp, I);
      FErrInfo := 'Error '+IntTostr(LR)+':'+LTemp;
    end
    else
      FErrInfo := 'Error '+IntTostr(LR)+':'+SysErrorMessage(GetLastError);
end;
end;

procedure TWnDownClass.CleanUp(isAll: Boolean);
begin
if isAll then
begin
    if Assigned(FRequest) then
    begin
      InternetCloseHandle(FRequest);
      FRequest := nil;
    end;
    if Assigned(FSession) then
    begin
      InternetCloseHandle(FSession);
      FSession := nil;
    end;
    if Assigned(FNet) then
    begin
      InternetCloseHandle(FNet);
      FNet := nil;
    end;
end;
//FResponse.Clear;
SetLength(FProxy,0);
end;

function TWnDownClass.ConfigureRequest: Boolean;
function SetUPD(AOption: DWORD; AUPD: PChar): Boolean;
begin
    Result := (Length(AUPD) =0)
      or InternetSetOption(FRequest, AOption, AUPD, Length(AUPD));
end;
begin
Result := False;
if FAbort then Exit;
//设置HTTP头
if FFileSize >0 then
begin
    if Length(FHttpHeader) > 0 then
      FHttpHeader := FHttpHeader + #13#10'Range: bytes='+ IntToStr(FFileSize) +'-'#13#10
    else
      FHttpHeader := 'Range: bytes='+ IntToStr(FFileSize) +'-'#13#10;
end;
if Length(FHttpHeader) > 0 then
begin
    Result := HttpAddRequestHeaders(FRequest, PWideChar(FHttpHeader),
      Cardinal(-1), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);

    if not Result then
    begin
      AssignError(wwecConfigureRequest);
      Exit;
    end;
end;
//设置超时
if (FTimeOut < 1) or (FTimeOut > 30) then FTimeOut := 30;
FTimeOut := FTimeOut * 1000;
Result := InternetSetOption(FNet, INTERNET_OPTION_CONNECT_TIMEOUT,
      @FTimeOut, SizeOf(Integer)) and
    InternetSetOption(FNet, INTERNET_OPTION_RECEIVE_TIMEOUT, @FTimeOut,
      SizeOf(Integer)) and
    InternetSetOption(FNet, INTERNET_OPTION_SEND_TIMEOUT, @FTimeOut,
      SizeOf(Integer));

if not (Result) then
begin
    AssignError(wwecTimeOut);
    Exit;
end;
//设置代理用户密码，访问用户密码
if SetUPD(INTERNET_OPTION_PROXY_USERNAME,PChar(FProxyInfo.FProxyUserName))
    and SetUPD(INTERNET_OPTION_PROXY_PASSWORD,PChar(FProxyInfo.FProxyUserPass))
    and SetUPD(INTERNET_OPTION_USERNAME,PChar(fServerPass))
    and SetUPD(INTERNET_OPTION_PASSWORD,PChar(FServerUser))
    then
else
    AssignError(wwecUPD);

end;

constructor TWnDownClass.Create;
begin
inherited;
FResponse := TMemoryStream.Create;
FRequest := nil;
FSession := nil;
FNet := nil;
//FKeepConnected := False;
FAbort := False;
FWininetStateChanged := False;
FErrInfo := '';
FEncodeUrl := '';
FServerUser := '';
FServerPass := '';
FVerb := 'GET';
FStatus := -1;
FFileSize := 0;
SetLength(FProxy,0);
end;

destructor TWnDownClass.Destroy;
begin
FResponse.Free;
inherited;
end;

function TWnDownClass.DetectProxyServer: DWORD;
begin
   //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
//Result:
//INTERNET_OPEN_TYPE_PRECONFIG                   0
//INTERNET_OPEN_TYPE_DIRECT                      1
//INTERNET_OPEN_TYPE_PROXY                       3
//INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY 4
with FProxyInfo do
case (FProxyType-1) of
    0: Result := INTERNET_OPEN_TYPE_DIRECT;
    1:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('socks=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
    2:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('socks5=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
    3:
    begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format('%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
    end;
else
      Result := INTERNET_OPEN_TYPE_PRECONFIG;
end;
end;
function TWnDownClass.FetchHeader(AFlags: Integer): Boolean;
var
BufLen, Index: DWORD;
begin
Result := False;
if FAbort then Exit;
Index := 0;
BufLen := BUFFER_SIZE;
FillChar(FData,BufLen,0);
Result := HttpQueryInfo(FRequest, AFlags, @FData, BufLen, Index);
end;

function TWnDownClass.FixContentLength: Boolean;
var
LTemp: string;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_LENGTH);
LTemp := FData;
if Result then
    FContentLength := StrToInt64Def(LTemp,0)
else
    AssignError(wwecContentLength);
end;

function TWnDownClass.FixContentType: Boolean;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_TYPE);
if Result then
    FContentType := FData
else
    AssignError(wwecContentType);
end;

procedure TWnDownClass.FixProxyServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
    ls1ServerName := LowerCase(FProxyInfo.FProxyServer);
    liLoc := Pos(':', ls1ServerName);
    if liLoc = 0 then Exit;
    lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
    FProxyInfo.FProxyServer := PChar(Copy(ls1ServerName, 1, liLoc - 1));
    FProxyInfo.FProxyPort := StrToIntDef(lsPort,FProxyInfo.FProxyPort);
except
end;
end;

procedure TWnDownClass.FixServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
    ls1ServerName := LowerCase(FServerName);
    liLoc := Pos(':', ls1ServerName);
    if liLoc = 0 then Exit;
    lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
    FServerName := PChar(Copy(ls1ServerName, 1, liLoc - 1));
    FServerPort := StrToIntDef(lsPort,FServerPort);
except
end;
end;

function TWnDownClass.FixWinINetError(AError: Integer): string;
{var
I, H: Integer;
begin
H := GetModuleHandle('wininet.dll');
SetLength(Result, 256);
I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), AError, 0,
    PChar(Result), 256, nil);
SetLength(Result, I);
end; }
begin
Result := 'Http Status: '+ IntToStr(AError);
end;

procedure TWnDownClass.HookDataReadSized;
//var
//nTransPercent: Integer;
begin
//if IsWindow(hNotify) then
//begin

if Assigned(FOnDownloadProgress) then
    FOnDownloadProgress(FTotal + FFileSize,FContentLength + FFileSize);

// PostMessage(hNotify, WM_HTTPCOMM_PROGRESS, Integer(pUserData),
//    nTransPercent);
//end;
end;

function TWnDownClass.HttpGet(isUrl: string; iiTimeout: integer; ASecure: Boolean): boolean;
begin
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FSecure := ASecure;
FTimeOut := iiTimeout;
FTotal := 0;
{ TODO : 不知道是否需要UTF8编码 }
//FEncodeUrl := isUrl; //EncodeUrlUtf8(FEncodeUrl);
FEncodeUrl := HttpEncode(UTF8Encode(isUrl));
FVerb := 'GET';
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformGet;
CleanUp(True);
end;

function TWnDownClass.OpenConnection: Boolean;
var
LProxyType: DWORD;

function WW_AttemptConnect: Boolean;
begin
    Result := (CompareText(FServerName, 'localhost') = 0) or
      (InternetAttemptConnect(0) = ERROR_SUCCESS);
    if not (Result) then AssignError(wwecAttemptConnect);
end;

procedure CancelMaxConnectLimite();
var
    liPerServer1, liPerServer2: Integer;
begin
    try
      liPerServer1 := 5;
      liPerServer2 := 10;
      //INTERNET_OPTION_MAX_CONNS_PER_SERVER 73
      InternetSetOption(nil, 73, @liPerServer1, SizeOf(Integer));
      //INTERNET_OPTION_MAX_CONNS_PER_1_0_SERVER 74
      InternetSetOption(nil, 74, @liPerServer2, SizeOf(Integer));
    except
    end;
end;

function WW_InternetOpen: Boolean;
var
    ltInfo: INTERNET_CONNECTED_INFO;
begin
    FNet := InternetOpen(PChar(InnerAgent), LProxyType, PChar(FProxy), nil, 0);

    Result := (FNet <> nil);
    if Result then begin
      try
        if not FWininetStateChanged then begin
          //INTERNET_OPTION_CONNECTED_STATE 50
          //取消IE的脱机状态
          ltInfo.dwConnectedState := INTERNET_STATE_CONNECTED;
          ltInfo.dwFlags := 0;          // ISO_FORCE_DISCONNECTED;
          InterNetSetOption(FNet, INTERNET_OPTION_CONNECTED_STATE, @ltInfo, SizeOf(ltInfo));
        end;
      except
      end;
      //InternetSetStatusCallBack(FNet, @StatusCallBack);
      //INTERNET_OPTION_HTTP_DECODING

      if InternetSetOption(FNet, 65, @Result, 1) then begin
        Beep;
      end;
    end else begin
      AssignError(wwecOpen);
    end;
end;

function WW_InternetConnect: Boolean;
var
    context: dword;
begin
    //同步通讯设置
    context := 0;
    //异步通讯需要设置特定值
    //FCallBackContext.CallbackID := 0;
    //context:=dword(@FCallBackContext);
    FSession := InternetConnect(FNet, PChar(FServerName),
        PortToUse(FServerPort), '', '', INTERNET_SERVICE_HTTP, 0, context);
    Result := (FSession <> nil);
    if not (Result) then AssignError(wwecConnect);
end;

begin
Result := False;
if FAbort then Exit;
if WW_AttemptConnect then
begin
    LProxyType := DetectProxyServer;
    SetLastError(0);
    if not FWininetStateChanged then CancelMaxConnectLimite();
    Result := WW_InternetOpen and WW_InternetConnect;
    FWininetStateChanged := True;
end;
end;

function TWnDownClass.OpenRequest: Boolean;
var
context,ATimeOut, dwFlags: DWORD;
begin
Result := False;
if FAbort then Exit;
context := 0;
if FSecure then
begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb),
      PChar(FEncodeUrl), PChar(HttpVersion), nil, nil, INTERNET_FLAG_KEEP_CONNECTION or
      INTERNET_FLAG_SECURE or SECURITY_FLAG_IGNORE_UNKNOWN_CA or
      SECURITY_FLAG_IGNORE_CERT_CN_INVALID or
      SECURITY_FLAG_IGNORE_CERT_DATE_INVALID, context);
    ATimeOut := 0;
    dwFlags := 0;

    if (FRequest <> nil) and
      (not InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS,
      Pointer(@ATimeOut), dwFlags)) then
    begin
      GetLastError;
    end;
end
else
begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb),
      PChar(FEncodeUrl), PChar(HttpVersion), nil, nil, {Ord(FSecure) * INTERNET_FLAG_SECURE or}
      INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD or
      INTERNET_FLAG_KEEP_CONNECTION , context);
end;
Result := (FRequest <> nil);
if not (Result) then AssignError(wwecOpenRequest);
end;

function TWnDownClass.PerformGet: Boolean;
var
AtimeOut, dwFlags: DWORD;
//LErr: Cardinal;
begin
Result := False;
if FAbort then Exit;
Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
//Result := HTTPSendRequest(FRequest, D_C_T, D_C_T_S, nil, 0);
if not (Result) then
begin
    if GetLastError = ERROR_INTERNET_INVALID_CA then //WinInet 无效证书颁发机构错误
    begin
      ATimeOut := 0;
      dwFlags := 0;
      InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, Pointer(@ATimeOut), dwFlags);
      dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
      InternetSetOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, SizeOf(Integer));
      Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
    end
    else
    begin
      AssignError(wwecExecRequest);
      Exit;
    end;
end;
Result := FetchHeader(HTTP_QUERY_STATUS_CODE);
if not Result then
begin
    AssignError(wwecStatus);
    Exit;
end;
FStatus := StrToIntDef(FData, -1);
if (FStatus = HTTP_STATUS_OK) or (FStatus = HTTP_STATUS_PARTIAL_CONTENT) then
begin
    Result := FixContentLength and FixContentType and ReadResponse;
end
else
begin
    FErrInfo := FixWinINetError(FStatus);
    AssignError(wwecStatus);
end;
end;

function TWnDownClass.PortToUse(APort: Integer): Integer;
begin
if APort > 0 then
    Result := APort
else
    if FSecure then
      Result := INTERNET_DEFAULT_HTTPS_PORT
    else
      Result := INTERNET_DEFAULT_HTTP_PORT;
end;

function TWnDownClass.ReadResponse: Boolean;
var
ASize, ARead: DWORD;
ABuffer: Pointer;
begin
Result := False;
if FAbort then Exit;
FResponse.Clear;
ASize := BUFFER_SIZE;
FTotal := 0;
ABuffer := AllocMem(ASize);
try
    HookDataReadSized;
    repeat
      Result := InternetReadFile(FRequest, ABuffer, ASize, ARead);
      if not Result then
      begin
        AssignError(wwecReadFile);
        Break;
      end;
      if (ARead > 0) then
      begin
        FResponse.WriteBuffer(ABuffer^, ARead);
        Inc(FTotal, ARead);
        HookDataReadSized;
      end;
    until ((ARead = 0) or FAbort);
finally
    FreeMem(ABuffer, 0);
end;
end;

procedure TWnDownClass.SetAbort(const Value: Boolean);
begin
FAbort := Value;
if FAbort then
begin
    FErrorCause := wwecAbort;
    FErrInfo := 'User Download Abouted';
end;
end;

procedure TWnDownClass.SetOnDownloadProgress(const Value: TOnDownloadProgress);
begin
FOnDownloadProgress := Value;
end;

end.

本文链接

Dephi调用C#编写的WebService的一些问题与解决（转）

2011-08-05T05:19:00Z

转至：http://www.cnblogs.com/Equn93/archive/2010/04/27/1722070.html

问题1：服务端接收的所有中文都是"?????"(乱码)
解决：设置HTTPRIO控件的HTTPRIO.HTTPWebNode.UserUTF8InHeader属性为true

问题2：Dephi编写的客户端在windows2003下调用WebService提示"Access violation at address 00E59195. Write of address 00E59195"
解决：我的电脑属性->高级->性能->设置->数据执行保护。选中"只为关键 Windows 程序和服务启用数据执行保护。当然你可以选择另一个选项，并添加我们的客户端作为例外处理。有二点比较奇怪的，一、并不是每一台windows2003的机器都需要这样设置；二、有问题的2003机器使用.net写的客户端却能正常访问WebService。

问题3：从服务端得到的XML字符串，一分析就出错
解决：先使用WideString变量保存返回的XML字符串。再利用这个变量分析。string不能识别换行符。

问题4：服务端得到的参数都为空值
解决：检查一下引入的WebService单元的最后三行是否如下
initialization
InvRegistry.RegisterInterface(TypeInfo(YourWebServiceSoap), 'http://tempuri.org/', 'utf-8');
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(YourWebServiceSoap), 'http://tempuri.org/%operationName%');
InvRegistry.RegisterInvokeOptions(TypeInfo(YourWebServiceSoap), ioDocument);//这一行有时会没有
end.
这一行 InvRegistry.RegisterInvokeOptions(TypeInfo(YourWebServiceSoap), ioDocument);有时候没有的。举个例子，当我们的WebService的其中一个方法有参数的类型为DataSet时，单元文件的最后几行是这样的
initialization
InvRegistry.RegisterInterface(TypeInfo(YourWebServiceSoap), 'http://tempuri.org/', 'utf-8');
InvRegistry.RegisterDefaultSOAPAction(TypeInfo(YourWebServiceSoap), 'http://tempuri.org/%operationName%');
RemClassRegistry.RegisterXSClass(GetDataSetResult, 'http://tempuri.org/', GetDataSetResult);
RemClassRegistry.RegisterXSClass(updateSet, 'http://tempuri.org/', 'updateSet');
end.
这时，服务端接收到的所有参数都为null；这里你所手工在中间加入上面所提到的那一行。

问题5：服务端方法返回的DateTime，Delphi取得的时间不对。
解决：引用后，delphi是用TXSDateTime来接收C#的DateTime变量的。TXSDateTime有两个属性AsDateTime、AsUTCDateTime都是TDateTime，也就是Delphi用的日期变量了，但这两个属性得到的时间是不对的。放断点可以观察到TXSDateTime的年、月、时各变量都是正确的，所以解决的方式是取年月时分各变量重新组合成时间变量。
在这个过程，我碰到一个有趣的情况。看下面的C#代码

[WebMethod(EnableSession=true)]
public DateTime MyTime()
{
    DateTime cur = DateTime.Now;
    return cur;
}

[WebMethod(EnableSession=true)]
public DateTime YourTime(DateTime pTime)
{
    return pTime.AddDays(1);
}

Delphi调用后者，TXSDateTime中的AsDateTime属性保存的时间是对的。调用MyTime()，AsDateTime保存的时间就不对! 我以为AsUTCDateTime的情况可能会有所不同，但其实这里他与AsDateTime是一样的。另外，.net能不能再做些什么呢？我注意到.net的DateTime有这么一个方法ToUniversalTime；我在MyTime中尝试应用这个方法，结果更遭，delphi得到的年时分各变量的值不对了；期待AsUTCDateTime会给我惊喜，结果他还是与AsDateTime非常的一致；结果都不对。

本文链接

关于Window的快捷方式，图标缓存的清理

2011-05-16T05:42:00Z

在打包的时候会发现图标，总是不对，或者有时候桌面快捷方式的图标都丢失了

可以用以下脚本试试，摘至（

http://hi.baidu.com/shaoping007/blog/item/2393bb1e8bd8260f41341750.html

）：

解决：只需重组系统图标缓存即可。

这里有个批处理很好用
把下面的文字复制到文本文档，改后缀名为.bat，双击运行，ok

rem 关闭Windows外壳程序explorer

taskkill /f /im explorer.exe

rem 清理系统图标缓存数据库

attrib -h -s -r "%userprofile%\AppData\Local\IconCache.db"

del /f "%userprofile%\AppData\Local\IconCache.db"

attrib /s /d -h -s -r "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\*"

del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_32.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_96.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_102.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_256.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_1024.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_idx.db"
del /f "%userprofile%\AppData\Local\Microsoft\Windows\Explorer\thumbcache_sr.db"

rem 清理系统托盘记忆的图标

echo y|reg delete "HKEY_CLASSES_ROOT\Local Settings\Software\Microsoft\Windows\CurrentVersion\TrayNotify" /v IconStreams
echo y|reg delete "HKEY_CLASSES_ROOT\Local Settings\Software\Microsoft\Windows\CurrentVersion\TrayNotify" /v PastIconsStream

rem 重启Windows外壳程序explorer

start explorer

本文链接

Delphi 备忘五

2011-05-13T09:08:00Z

1. Variant和Stream的互换

procedure VarToStream(var AStm: TStream; var AOvar: Olevariant);
var
p: Pointer;
begin
AStm:= TMemoryStream.Create;
AStm.Position := 0;
p := VarArrayLock(AOvar);
AStm.Write(p^, VarArrayHighBound(AOvar, 1));
VarArrayUnlock(AOvar);
end;

procedure StreamToVar(var AStm: TStream; var AOvar: Olevariant);
var
p: Pointer;
begin
AOvar := VarArrayCreate([0, AStm.Size - 1], VarByte);
p := VarArrayLock(AOvar);
AStm.ReadBuffer(p^, AStm.Size);
VarArrayUnlock(AOvar);
end;

2. 判断文件是否在用

{createfile里面的第三个参数为dwShareMode ，使用如下（详见createfile的API）
[in] The sharing mode of an object, which can be read, write, both, or none.
You cannot request a sharing mode that conflicts with the access mode that is specified in an open request that has an open handle, because that would result in the following sharing violation: ERROR_SHARING_VIOLATION). For more information, see Creating and Opening Files.

If this parameter is 0 (zero) and CreateFile succeeds, the object cannot be shared and cannot be opened again until the handle is closed. For more information, see the Remarks section of this topic.

}

function IsFileInUse(const AFileName: string): Boolean;
var
  HFileRes: HFILE;
begin
  Result := false;
  if not FileExists(AFileName) then //如果文件不存在
    exit;
  HFileRes := CreateFile(pchar(AFileName), GENERIC_READ or GENERIC_WRITE,
    0 {this is the trick!}, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (HFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(HFileRes);
end;

本文链接

http断点续传的单元

2011-04-09T01:46:00Z

{******************************************************************************
    文件名称： uWnDownLoadHelper.pas
    文件功能：断点续传下载线程单元
    作者    ： enli
--------------------------------------------------------------------------------}

unit uWnDownLoadHelper;

interface

uses
  IdHTTP, IdAuthentication, IdHeaderList, IniFiles, md5,
  SysUtils, IdAuthenticationSSPI, IdAuthenticationDigest, Classes, IdException,
  IdSocks, IdIOHandlerSocket, DateUtils, IdComponent, Forms,ucchttpClient;

const
  S_TMP_POSTFIX = '.tmp';
  S_INI_POSTFIX = '.sni';

type
  TWnDownloadProgress = procedure(APosition,ACount: Int64) of object;

  // 代理设置结构
  TWnProxySetting = packed record
    FIsProxyEnabled: Boolean;
    FSocksVersion: TSocksVersion;
    FProxyHost: string;
    FProxyPort: Word;
    FAuthUserName: string;
    FAuthPassword: string;
    FAuthDomain:string;
  end;
  PWnProxySetting = ^TWnProxySetting;

  TWnDownLoadThread = class(TThread)
  private
    FHttp: TCCHTTPClient;
    FProxy: TWnProxySetting;
    FTarget: string;
    FSaveFile: string;
    FTempFile: string;
    FProgress: TWnDownloadProgress;
    FCurrentFileSize,FFileSize : Int64;
    FSaveLocation: string;
    FOnLog: TDolog;
    FWarningMsg: string;
    FReLoad: Boolean;
    procedure SetProxy(const Value: PWnProxySetting);
    function GetProxy :PWnProxySetting;
    procedure SetHttpProxy;
    procedure SetTarget(const Value: string);
    procedure SetProgress(const Value: TWnDownloadProgress);
    procedure DoBeginWork(Sender: TObject;const APos,ACount: Int64);
    procedure DoWork(Sender: TObject;const AWork:Int64);
    procedure DoEndWork(Sender: TObject);
    procedure DoUpdateUI;
    procedure SetSaveLocation(const Value: string);
    procedure SaveIniFile;
    procedure DelIniFile;
    procedure DoLog(const AMsg:string);
    procedure DoSycLog;
    function GetTempFile:string;
    procedure SetOnLog(const Value: TDolog);
    procedure SetReLoad(const Value: Boolean);
  public
    procedure Execute; override;
    constructor Create;
    destructor Destroy; override;
    class procedure chunkedConvertToFile(const ASource,ADestination:string);
    property PProxy:PWnProxySetting read GetProxy write SetProxy;
    property Target:string read FTarget write SetTarget;
    property SaveLocation :string read FSaveLocation write SetSaveLocation;
    property Progress:TWnDownloadProgress read FProgress write SetProgress;
    property ReLoad:Boolean read FReLoad write SetReLoad;
    property OnLog: TDolog read FOnLog write SetOnLog;
  end;

  procedure DownLoadFile(const AUrl,ASaveFile:string;AProxy:PWnProxySetting;AProgress:TWnDownloadProgress;ALog:TDolog;AReLoad:Boolean);

implementation

procedure DownLoadFile(const AUrl,ASaveFile:string;AProxy:PWnProxySetting;AProgress:TWnDownloadProgress;ALog:TDolog;AReLoad:Boolean);
var
  LThread: TWnDownLoadThread;
begin
  LThread := TWnDownLoadThread.Create;
  LThread.ReLoad := AReLoad;
  LThread.Target := AUrl;
  LThread.SaveLocation := ASaveFile;
  LThread.PProxy := AProxy;
  LThread.Progress :=AProgress;
  LThread.OnLog := ALog;
  LThread.Resume;
end;

{ TWnDownLoadThread }

class procedure TWnDownLoadThread.chunkedConvertToFile(const ASource,
  ADestination: string);
var
  LSStream,LDStream: TFileStream;
  LBuff: Byte;
  LFlag: Boolean;
  LTemp : string;
  I,LCount : Integer;
begin
  if not FileExists(ASource) then Exit;
  if FileExists(ADestination) then Exit;
  LSStream := TFileStream.Create(ASource,fmOpenRead    );
  LDStream := TFileStream.Create(ADestination,fmCreate);
  try
    LSStream.Seek(0,0);
    LFlag := True;
    I := 0;
    while LFlag do
    begin
      LSStream.Read(LBuff,SizeOf(Byte));
      Inc(I);
      if (LBuff = $0A) and (I>2) and (LTemp[I-1] = #$0D) then begin
        LCount := StrToIntDef('$'+trim(LTemp),1);
        if LCount = 1 then
        begin
          LCount := 0;
          Break;
          //raise 异常
        end;
        if LCount = 0 then
          LFlag := False
        else
        begin
          LDStream.CopyFrom(LSStream,LCount);
          I := 0;
          LTemp := '';
        end;
      end
      else
        LTemp := LTemp + Char(LBuff);
    end;

  finally
    FreeAndNil(LSStream);
    FreeAndNil(LDStream);
  end;

end;

constructor TWnDownLoadThread.Create;
begin
  inherited Create(True);
  FreeOnTerminate := True;
  FTarget := '';
  FSaveFile := '';
  //New(FProxy);
end;

procedure TWnDownLoadThread.DelIniFile;
begin
  DeleteFile(FSaveLocation + FTempFile+S_INI_POSTFIX);
end;

destructor TWnDownLoadThread.Destroy;
begin
  //Dispose(FProxy);
  inherited;
end;

procedure TWnDownLoadThread.DoBeginWork(Sender: TObject;
  const APos,ACount: Int64);
begin
  FFileSize := ACount;
  FCurrentFileSize := APos ;
  SaveIniFile;
  Synchronize(DoUpdateUI);
end;

procedure TWnDownLoadThread.DoEndWork(Sender: TObject);
begin
  FCurrentFileSize := FFileSize;
  Synchronize(DoUpdateUI);
end;

procedure TWnDownLoadThread.DoLog(const AMsg: string);
begin
  if Assigned(FOnlog) then
  begin
    ///DoDownLoadLog(AMsg);
    FWarningMsg:= AMsg;
    Synchronize(DoSycLog);
  end;
end;

procedure TWnDownLoadThread.DoSycLog;
begin
  FOnlog(FWarningMsg);
end;

procedure TWnDownLoadThread.DoUpdateUI;
begin
  if Assigned(FProgress) then
    FProgress(FCurrentFileSize,FFileSize);
end;

procedure TWnDownLoadThread.DoWork(Sender: TObject; const AWork: Int64);
begin
  FCurrentFileSize := FCurrentFileSize+ AWork;
  Synchronize(DoUpdateUI);
end;

procedure TWnDownLoadThread.Execute;
var
  LDoc,
  LHost,
  LPath,
  LProto,
  LPort,
  LBookmark: string;
begin
  if Length(FTarget) = 0 then Exit;
  if Length(FSaveLocation) = 0 then Exit;
  FHttp := TCCHTTPClient.Create(nil);
  try
    FHttp.IOHandler := TIdIOHandlerSocket.Create(FHttp);
    FHttp.Socket.SocksInfo := TIdSocksInfo.Create(FHttp);
    FHttp.ProtocolVersion := uCCHTTPClient.pv1_1;
    SetHttpProxy;
    FHttp.OnDownloadBegin :=  DoBeginWork;
    FHttp.OnDownload :=  DoWork;
    FHttp.OnDownloadEnd := DoEndWork;
    FHttp.OnLog := DoLog;

    FHttp.ParseURI(FTarget, LProto, LHost, LPath, LDoc, LPort, LBookmark);
    FSaveFile := LDoc;
    FTempFile := GetTempFile+'.'+LDoc;
    if FReLoad and FileExists(FSaveLocation + FTempFile+S_TMP_POSTFIX) then
      DeleteFile(FSaveLocation + FTempFile+S_TMP_POSTFIX);
    DoLog('下载开始请求');
    try
      FHttp.DownLoad(FTarget,FSaveLocation + FTempFile+S_TMP_POSTFIX);
    except
      on E:Exception do
        DoLog(e.Message);
    end;
    if FileExists(FSaveLocation + FTempFile+S_INI_POSTFIX) then
    begin

      if FileExists(FSaveLocation + LDoc) then
        DeleteFile(FSaveLocation + LDoc);
      if FHttp.Response.TransferEncoding = 'chunked' then
      begin
        chunkedConvertToFile(FSaveLocation + FTempFile+S_TMP_POSTFIX,FSaveLocation + LDoc);
        DeleteFile(FSaveLocation + FTempFile+S_TMP_POSTFIX);
      end
      else
        RenameFile(FSaveLocation + FTempFile+S_TMP_POSTFIX,FSaveLocation + LDoc);
      DelIniFile;
    end
    else
      DeleteFile(FSaveLocation + FTempFile+S_TMP_POSTFIX);
  finally
    FreeAndNil(FHttp);
    DoLog('下载结束');
  end;
end;

function TWnDownLoadThread.GetProxy: PWnProxySetting;
begin
  Result := @FProxy
end;

function TWnDownLoadThread.GetTempFile: string;
var
  Ltemp: string;
begin
  Ltemp := MD5Print(MD5String(FTarget));
  //Ltemp := copy(Ltemp, 2, length(Ltemp) - 2);
  Result := StringReplace(Ltemp,'-','.',[rfReplaceAll]    );
end;

procedure TWnDownLoadThread.SaveIniFile;
var
  LIni:TIniFile;
begin
  LIni := TIniFile.Create(FSaveLocation + FTempFile+S_INI_POSTFIX);
  try
    LIni.WriteString('Setup','URL',FTarget);
    LIni.WriteString('Setup','SaveLocation',FSaveLocation);
    LIni.WriteString('Setup','SaveFile',FSaveFile);
    LIni.WriteString('Setup','TempFile',FTempFile);
    LIni.WriteString('Setup','FileSize',FloatToStr(FFileSize));
  finally
    LIni.Free;
  end;

end;

procedure TWnDownLoadThread.SetHttpProxy;
begin
  if not Assigned(FHttp) then Exit;
  with FProxy do
  if FIsProxyEnabled then
  begin
    FHttp.Socket.SocksInfo.Version := FSocksVersion;
    FHttp.Socket.SocksInfo.Host := FProxyHost;
    FHttp.Socket.SocksInfo.Port := FProxyPort;

    if FHttp.Socket.SocksInfo.Username <> '' then
      FHttp.Socket.SocksInfo.Authentication := saUsernamePassword
    else
      FHttp.Socket.SocksInfo.Authentication := saNoAuthentication;
    FHttp.AuthUsername := FAuthUserName;
    FHttp.AuthPassword := FAuthPassword;
    FHttp.AuthDomain   := FAuthDomain;
    FHttp.ProxyHost    := FProxyHost;
    FHttp.ProxyPort    := FProxyPort;
  end;
end;

procedure TWnDownLoadThread.SetOnLog(const Value: TDolog);
begin
  FOnLog := Value;
end;

procedure TWnDownLoadThread.SetProgress(const Value: TWnDownloadProgress);
begin
  FProgress := Value;
end;

procedure TWnDownLoadThread.SetProxy(const Value: PWnProxySetting);
begin
    //New(FProxy);
    FProxy.FIsProxyEnabled :=Value^.FIsProxyEnabled;
    FProxy.FSocksVersion := Value^.FSocksVersion;
    FProxy.FProxyHost := Value^.FProxyHost;
    FProxy.FProxyPort := Value^.FProxyPort;
    FProxy.FAuthUserName := Value^.FAuthUserName;
    FProxy.FAuthPassword := Value^.FAuthPassword;
    FProxy.FAuthDomain   := Value^.FAuthDomain;
    FProxy.FProxyHost   := Value^.FProxyHost;
    FProxy.FProxyPort    := Value^.FProxyPort;

end;

procedure TWnDownLoadThread.SetReLoad(const Value: Boolean);
begin
  FReLoad := Value;
end;

procedure TWnDownLoadThread.SetSaveLocation(const Value: string);
begin
  FSaveLocation := Value;
  if FSaveLocation[Length(FSaveLocation)] <> '\' then
    FSaveLocation := FSaveLocation +'\';
end;

procedure TWnDownLoadThread.SetTarget(const Value: string);
begin
  if Length(Value) = 0 then Exit;
  if UpperCase(Copy(Value,1,7)) <> 'HTTP://' then Exit;
  FTarget := Value;
end;

end.

备忘：IdDownLoad

本文链接

博客园_闲云野鹤

Wininet请求包装类简稿

自备工具库

多屏开发的备忘

界面方面的备忘

rc资源文件的中英文应用备忘

Wininet下载类初稿

Dephi调用C#编写的WebService的一些问题与解决 （转）

关于Window的快捷方式，图标缓存的清理

Delphi 备忘五

http断点续传的单元

Dephi调用C#编写的WebService的一些问题与解决（转）