精华内容
下载资源
问答
  • delphi源码分析.pdf

    2012-11-11 14:19:23
    delphi源码分析.pdf
  • Delphi源码分析抽取工具,V0.1,内部测试,目前只能构建粗略的代码结构树,请感兴趣的朋友帮忙测试,异常假死在所难免.
  • Delphi源码分析抽取工具,内部测试,目前只能构建粗略的代码结构树,请感兴趣的朋友帮忙测试,异常假死在所难免,这两天有所改善,分析内容更多
  • Delphi源码分析抽取工具,目前能够构建代码结构树.应部分网友要求,增加了类名列表、过程/函数列表、单元列表、文件列表等实用功能
  • 本书通过对Delphi内核(RTL)源代码进行分析,深入阐述了Delphi内核(RTL)的原理及其实现。全书从Nico Bendlin编写的著名最小化内核示例程序MiniDExe讲起,基于MiniDExe分析Delphi在编译器一级的技术内幕,带领读者...
  • Delphi源码分析软件

    2010-09-29 22:21:38
    集成了Delphi4至Delphi2010编译器,能生成完整的类继承树报告、函数(过程)调用树报告等
  • Delphi源码分析设计图

    2007-08-15 21:22:08
    delphi工程文件引入,输出全部的class diagram, 学习delphi的好工具,open source <br> 非常棒的工具,相当于modelmaker的反向工具,嘿嘿,读代码的速度大大提高
  • 2019独角兽企业重金招聘Python工程师标准>>> ...

    该部分的函数都是根据制定参数返回其对应的开始时间和结束时间,根据不同参数以及不同的返回需求,在预定义函数中拆分参数,并重新组装,返回一个新的合法值。

    下面是Start/End functions部分函数示例及说明

    代码示例


    转载于:https://my.oschina.net/u/140474/blog/496277

    展开全文
  • 线性回归分析Delphi源码线性回归分析Delphi源码
  • 一个直接支持打开Excel 文件,然后, 直接使用SQL语言进行查询的工具,附源码。 使用说明: 1、安装accessDatabaseEngine.exe,使电脑支持Microsoft.ACE.OLEDB支持 2、使用delphi 7 编译运行应用
  • 可以分析Delphi编译生成的Exe可执行程序引用了哪些单元,及单元模块之间的关系
  • 在这篇文章中,我将大概的从Delphi XE2 的Dialogs单元入手,分析ShowMessage,MessageBox等对话框运行原理,希望能帮助你理解Delphi,不求你爱上她,只求让你能快速地解决问题。 跟踪代码 为了了解这些对话框的...

     

    简介

    在这篇文章中,我将大概的从Delphi XE2 的Dialogs单元入手,分析ShowMessage,MessageBox等对话框运行原理,希望能帮助你理解Delphi,不求你爱上她,只求让你能快速地解决问题。

    跟踪代码

    为了了解这些对话框的运行原理,我们需要跟踪进源代码中去,为此,你需要做如下设置

    1. 简单创建一个使用了ShowMessage的VCL应用程序

    unit Unit1;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
      Dialogs, StdCtrls;
    
    type
      TForm1 = class(TForm)
        Edit1: TEdit;
        Button1: TButton;
        procedure Button1Click(Sender: TObject);
      private
        { Private declarations }
      public
        { Public declarations }
      end;
    
    var
      Form1: TForm1;
    
    implementation
    
    {$R *.dfm}
    
    procedure TForm1.Button1Click(Sender: TObject);
    begin
      ShowMessage(Edit1.Text);
      MessageBox(Self.Handle,PChar(Edit1.Text),PChar(Application.Title),
        MB_ICONINFORMATION or MB_OK);
      MessageDlg(Edit1.Text,mtInformation,[mbOK,mbCancel],0);
    end;
    
    end.
    

    DFM文件代码:

    object Form1: TForm1
      Left = 0
      Top = 0
      Caption = 'Form1'
      ClientHeight = 243
      ClientWidth = 472
      Color = clBtnFace
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'Tahoma'
      Font.Style = []
      OldCreateOrder = False
      PixelsPerInch = 96
      TextHeight = 13
      object Edit1: TEdit
        Left = 128
        Top = 72
        Width = 209
        Height = 21
        TabOrder = 0
        TextHint = 'Message here'
      end
      object Button1: TButton
        Left = 192
        Top = 120
        Width = 75
        Height = 25
        Caption = 'Message box'
        TabOrder = 1
        OnClick = Button1Click
      end
    end

    1

    2. 在29行里设置一个断点, 再在Edit里输入一些内容,按下Message Box按钮, 按F7跟踪到Dialogs单元, 经过一段时间的仔细跟踪, 你会发现程序运行到下面一段代码:

    function MessageDlgPosHelp(const Msg: string; DlgType: TMsgDlgType;
      Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
      const HelpFileName: string): Integer;
    begin
      if (Win32MajorVersion >= 6) and UseLatestCommonDialogs and ThemeServices.ThemesEnabled then
        Result := DoTaskMessageDlgPosHelp('', Msg, DlgType, Buttons,
          HelpCtx, X, Y, HelpFileName)
      else
        Result := DoMessageDlgPosHelp(CreateMessageDialog(Msg, DlgType, Buttons),
          HelpCtx, X, Y, HelpFileName);
    end;

    函数MessageDlgPosHelp指出, 如果当前系统是Vista,sever2008或以上版本的系统,那就调用DoTaskMessageDlgPosHelp函数进行对话框显示, 否则调用DoMessageDlgPosHelp显示对话框. 继续跟踪DoTaskMessageDlgPosHelp函数, 你会发现如下一段代码:

    function TCustomTaskDialog.DoExecute(ParentWnd: HWND): Boolean;
    const
      CTaskDlgFlags: array[TTaskDialogFlag] of Cardinal = (
        TDF_Enable_Hyperlinks, TDF_Use_Hicon_Main,
        tdf_Use_Hicon_Footer, TDF_ALLOW_DIALOG_CANCELLATION,
        TDF_USE_COMMAND_LINKS, TDF_USE_COMMAND_LINKS_NO_ICON,
        TDF_EXPAND_FOOTER_AREA, TDF_EXPANDED_BY_DEFAULT,
        TDF_VERIFICATION_FLAG_CHECKED, TDF_SHOW_PROGRESS_BAR,
        TDF_SHOW_MARQUEE_PROGRESS_BAR, TDF_CALLBACK_TIMER,
        TDF_POSITION_RELATIVE_TO_WINDOW, TDF_RTL_LAYOUT,
        TDF_NO_DEFAULT_RADIO_BUTTON, TDF_CAN_BE_MINIMIZED);
    
      CTaskDlgCommonButtons: array[TTaskDialogCommonButton] of Cardinal = (
        TDCBF_OK_BUTTON, TDCBF_YES_BUTTON, TDCBF_NO_BUTTON,
        TDCBF_CANCEL_BUTTON, TDCBF_RETRY_BUTTON, TDCBF_CLOSE_BUTTON);
    
      CTaskDlgDefaultButtons: array[TTaskDialogCommonButton] of Integer = (
        IDOK, IDYES, IDNO, IDCANCEL, IDRETRY, IDCLOSE);
    
    var
      LWindowList: TTaskWindowList;
      LModalResult: Integer;
      LRadioButton: Integer;
      LFlag: TTaskDialogFlag;
      LFocusState: TFocusState;
      LVerificationChecked: LongBool;
      LTaskDialog: TTaskDialogConfig;
      LCommonButton: TTaskDialogCommonButton;
    begin
      if Win32MajorVersion < 6 then
        raise EPlatformVersionException.CreateResFmt({$IFNDEF CLR}@{$ENDIF}SWindowsVistaRequired, [ClassName]);
      if not ThemeServices.ThemesEnabled then
        raise Exception.CreateResFmt({$IFNDEF CLR}@{$ENDIF}SXPThemesRequired, [ClassName]);
    
    {$IF NOT DEFINED(CLR)}
      FillChar(LTaskDialog, SizeOf(LTaskDialog), 0);
    {$IFEND}
      with LTaskDialog do
      begin
        // Set Size, Parent window, Flags
        cbSize := SizeOf(LTaskDialog);
        hwndParent := ParentWnd;
        dwFlags := 0;
        for LFlag := Low(TTaskDialogFlag) to High(TTaskDialogFlag) do
          if LFlag in FFlags then
            dwFlags := dwFlags or CTaskDlgFlags[LFlag];
    
        // Set CommonButtons
        dwCommonButtons := 0;
        for LCommonButton := Low(TTaskDialogCommonButton) to High(TTaskDialogCommonButton) do
          if LCommonButton in FCommonButtons then
            dwCommonButtons := dwCommonButtons or CTaskDlgCommonButtons[LCommonButton];
    
        // Set Content, MainInstruction, Title, MainIcon, DefaultButton
        if FText <> '' then
          pszContent := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FText));
        if FTitle <> '' then
          pszMainInstruction := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FTitle));
        if FCaption <> '' then
          pszWindowTitle := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FCaption));
        if tfUseHiconMain in FFlags then
          hMainIcon := FCustomMainIcon.Handle
        else
        begin
          if FMainIcon in [tdiNone..tdiShield] then
            pszMainIcon := LPCWSTR(CTaskDlgIcons[FMainIcon])
          else
            pszMainIcon := LPCWSTR(MakeIntResourceW(Word(FMainIcon)));
        end;
        nDefaultButton := CTaskDlgDefaultButtons[FDefaultButton];
    
        // Set Footer, FooterIcon
        if FFooterText <> '' then
          pszFooter := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FFooterText));
        if tfUseHiconFooter in FFlags then
          hFooterIcon := FCustomFooterIcon.Handle
        else
        begin
          if FFooterIcon in [tdiNone..tdiShield] then
            pszFooterIcon := LPCWSTR(CTaskDlgIcons[FFooterIcon])
          else
            pszFooterIcon := LPCWSTR(MakeIntResourceW(Word(FFooterIcon)));
        end;
    
        // Set VerificationText, ExpandedInformation, CollapsedControlText
        if FVerificationText <> '' then
          pszVerificationText := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FVerificationText));
        if FExpandedText <> '' then
          pszExpandedInformation := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FExpandedText));
        if FExpandButtonCaption <> '' then
          pszCollapsedControlText := {$IFNDEF CLR}PWideChar{$ENDIF}(WideString(FExpandButtonCaption));
    
        // Set Buttons
        cButtons := FButtons.Count;
        if cButtons > 0 then
          pButtons := FButtons.Buttons;
        if FButtons.DefaultButton <> nil then
          nDefaultButton := FButtons.DefaultButton.ModalResult;
    
        // Set RadioButtons
        cRadioButtons := FRadioButtons.Count;
        if cRadioButtons > 0 then
          pRadioButtons := FRadioButtons.Buttons;
        if not (tfNoDefaultRadioButton in FFlags) and (FRadioButtons.DefaultButton <> nil) then
          nDefaultRadioButton := FRadioButtons.DefaultButton.ModalResult;
    
        // Prepare callback
    {$IF DEFINED(CLR)}
        pfCallBack := @CallbackProc;
    {$ELSE}
        lpCallbackData := LONG_PTR(Self);
        pfCallback := @TaskDialogCallbackProc;
    {$IFEND}
      end;
    
      LWindowList := DisableTaskWindows(ParentWnd);
      LFocusState := SaveFocusState;
      try
        Result := TaskDialogIndirect(LTaskDialog, {$IFNDEF CLR}@{$ENDIF}LModalResult,
          {$IFNDEF CLR}@{$ENDIF}LRadioButton, {$IFNDEF CLR}@{$ENDIF}LVerificationChecked) = S_OK;
        FModalResult := LModalResult;
        if Result then
        begin
          FButton := TTaskDialogButtonItem(FButtons.FindButton(FModalResult));
          FRadioButton := TTaskDialogRadioButtonItem(FRadioButtons.FindButton(LRadioButton));
          if LVerificationChecked then
            Include(FFlags, tfVerificationFlagChecked)
          else
            Exclude(FFlags, tfVerificationFlagChecked);
        end;
      finally
        EnableTaskWindows(LWindowList);
        SetActiveWindow(ParentWnd);
        RestoreFocusState(LFocusState);
      end;
    end;
    

    上面这段代码在Dialogs单元的第5407行, 该函数先进行可用性判断, 然后填充

    LTaskDialog: TTaskDialogConfig;


    一个TTaskDialogConfig的结构体, 该结构体定义在CommCtrl单元第9550行, 其定义如下:

    type
      { $EXTERNALSYM TASKDIALOGCONFIG}
      TASKDIALOGCONFIG = packed record
        cbSize: UINT;
        hwndParent: HWND;
        hInstance: HINST;                     // used for MAKEINTRESOURCE() strings
        dwFlags: DWORD;                       // TASKDIALOG_FLAGS (TDF_XXX) flags
        dwCommonButtons: DWORD;               // TASKDIALOG_COMMON_BUTTON (TDCBF_XXX) flags
        pszWindowTitle: LPCWSTR;              // string or MAKEINTRESOURCE()
        case Integer of
          0: (hMainIcon: HICON);
          1: (pszMainIcon: LPCWSTR;
              pszMainInstruction: LPCWSTR;
              pszContent: LPCWSTR;
              cButtons: UINT;
              pButtons: PTaskDialogButton;
              nDefaultButton: Integer;
              cRadioButtons: UINT;
              pRadioButtons: PTaskDialogButton;
              nDefaultRadioButton: Integer;
              pszVerificationText: LPCWSTR;
              pszExpandedInformation: LPCWSTR;
              pszExpandedControlText: LPCWSTR;
              pszCollapsedControlText: LPCWSTR;
              case Integer of
                0: (hFooterIcon: HICON);
                1: (pszFooterIcon: LPCWSTR;
                    pszFooter: LPCWSTR;
                    pfCallback: TFTaskDialogCallback;
                    lpCallbackData: LONG_PTR;
                    cxWidth: UINT  // width of the Task Dialog's client area in DLU's.
                                   // If 0, Task Dialog will calculate the ideal width.
                  );
              );
      end;
      {$EXTERNALSYM _TASKDIALOGCONFIG}
      _TASKDIALOGCONFIG = TASKDIALOGCONFIG;
      PTaskDialogConfig = ^TTaskDialogConfig;
      TTaskDialogConfig = TASKDIALOGCONFIG;
    

    该结构体其实是从MSDN里翻译过来的, 定义在CommCtrl.h 头文件里(需要Windows Vista, Windows Server 2008及以上版本, 我是用Windows 7 64位进行的测试), 详细说明可以查看MSDN.

    TCustomTaskDialog.DoExecute 填充完LTaskDialog结构体后, 直接调用:

    Result := TaskDialogIndirect(LTaskDialog, {$IFNDEF CLR}@{$ENDIF}LModalResult,
          {$IFNDEF CLR}@{$ENDIF}LRadioButton, {$IFNDEF CLR}@{$ENDIF}LVerificationChecked) = S_OK;

    TaskDialogIndirect显示对话框, TaskDialogIndirect定义在CommCtrl单元, 其代码如下:

    { Task Dialog }
    
    var
      _TaskDialogIndirect: function(const pTaskConfig: TTaskDialogConfig;
        pnButton: PInteger; pnRadioButton: PInteger;
        pfVerificationFlagChecked: PBOOL): HRESULT; stdcall;
    
      _TaskDialog: function(hwndParent: HWND; hInstance: HINST;
        pszWindowTitle: LPCWSTR; pszMainInstruction: LPCWSTR; pszContent: LPCWSTR;
        dwCommonButtons: DWORD; pszIcon: LPCWSTR; pnButton: PInteger): HRESULT; stdcall;
    
    function TaskDialogIndirect(const pTaskConfig: TTaskDialogConfig;
      pnButton: PInteger; pnRadioButton: PInteger; pfVerificationFlagChecked: PBOOL): HRESULT;
    begin
      if Assigned(_TaskDialogIndirect) then
        Result := _TaskDialogIndirect(pTaskConfig, pnButton, pnRadioButton,
          pfVerificationFlagChecked)
      else
      begin
        InitComCtl;
        Result := E_NOTIMPL;
        if ComCtl32DLL <> 0 then
        begin
          @_TaskDialogIndirect := GetProcAddress(ComCtl32DLL, 'TaskDialogIndirect');
          if Assigned(_TaskDialogIndirect) then
            Result := _TaskDialogIndirect(pTaskConfig, pnButton, pnRadioButton,
              pfVerificationFlagChecked)
        end;
      end;
    end;
    

    查看代码知道, TaskDialogIndirect 直接调用ComCtrl32.Dll里的函数:TaskDialogIndirect  显示对话框. 通过查询MSDN了解TaskDialogIndirect API的用途与用法:

    The TaskDialogIndirect function creates, displays, and operates a task dialog. The task dialog contains application-defined icons, messages, title, verification check box, command links, push buttons, and radio buttons. This function can register a callback function to receive notification messages.

    函数TaskDialogIndirect 用于创建, 显示, 运行一个任务对话框, 这个任务对话框可以包括由应用程序定义的图标,消息,标题,复选框,按钮,单选框. 该函数还可以接收一个回调函数用于接收通知信息

    看到这里你或许会问:

    如果我的系统是xp或其他低于Vista, server2008的系统呢? 由上文中可知, 如果是低版本的系统, 则调用DoMessageDlgPosHelp 函数进行对话框显示, 调用代码如下:

    Result := DoMessageDlgPosHelp(CreateMessageDialog(Msg, DlgType, Buttons),
          HelpCtx, X, Y, HelpFileName);

    DoMessageDlgPosHelp代码:

    function DoMessageDlgPosHelp(MessageDialog: TForm; HelpCtx: Longint; X, Y: Integer;
      const HelpFileName: string): Integer;
    begin
      with MessageDialog do
        try
          HelpContext := HelpCtx;
          HelpFile := HelpFileName;
          if X >= 0 then Left := X;
          if Y >= 0 then Top := Y;
          if (Y < 0) and (X < 0) then Position := poScreenCenter;
          Result := ShowModal;
        finally
          Free;
        end;
    end;

    从DoMessageDlgPosHelp代码中可见, 该函数只是简单的将传递进来的TForm以模式窗口的形式显示在指定的位置.

    下面是CreateMessageDialog代码:

    function CreateMessageDialog(const Msg: string; DlgType: TMsgDlgType;
      Buttons: TMsgDlgButtons; DefaultButton: TMsgDlgBtn): TForm;
    const
      mcHorzMargin = 8;
      mcVertMargin = 8;
      mcHorzSpacing = 10;
      mcVertSpacing = 10;
      mcButtonWidth = 50;
      mcButtonHeight = 14;
      mcButtonSpacing = 4;
    var
      DialogUnits: TPoint;
      HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth,
      ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth,
      IconTextWidth, IconTextHeight, X, ALeft: Integer;
      B, CancelButton: TMsgDlgBtn;
    {$IF DEFINED(CLR)}
      IconID: Integer;
    {$ELSE}
      IconID: PChar;
    {$IFEND}
      TextRect: TRect;
      LButton: TButton;
    begin
      Result := TMessageForm.CreateNew(Application);
      with Result do
      begin
        BiDiMode := Application.BiDiMode;
        BorderStyle := bsDialog;
        Canvas.Font := Font;
        KeyPreview := True;
        PopupMode := pmAuto;
        Position := poDesigned;
        OnKeyDown := TMessageForm(Result).CustomKeyDown;
        DialogUnits := GetAveCharSize(Canvas);
        HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);
        VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);
        HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);
        VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);
        ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);
        for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
        begin
          if B in Buttons then
          begin
            if ButtonWidths[B] = 0 then
            begin
              TextRect := Rect(0,0,0,0);
              Windows.DrawText( canvas.handle,
    {$IF DEFINED(CLR)}
                ButtonCaptions[B], -1,
    {$ELSE}
                PChar(LoadResString(ButtonCaptions[B])), -1,
    {$IFEND}
                TextRect, DT_CALCRECT or DT_LEFT or DT_SINGLELINE or
                DrawTextBiDiModeFlagsReadingOnly);
              with TextRect do ButtonWidths[B] := Right - Left + 8;
            end;
            if ButtonWidths[B] > ButtonWidth then
              ButtonWidth := ButtonWidths[B];
          end;
        end;
        ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);
        ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);
        SetRect(TextRect, 0, 0, Screen.Width div 2, 0);
        DrawText(Canvas.Handle, Msg, Length(Msg)+1, TextRect,
          DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or
          DrawTextBiDiModeFlagsReadingOnly);
        IconID := IconIDs[DlgType];
        IconTextWidth := TextRect.Right;
        IconTextHeight := TextRect.Bottom;
    {$IF DEFINED(CLR)}
        if DlgType <> mtCustom then
    {$ELSE}
        if IconID <> nil then
    {$IFEND}
        begin
          Inc(IconTextWidth, 32 + HorzSpacing);
          if IconTextHeight < 32 then IconTextHeight := 32;
        end;
        ButtonCount := 0;
        for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
          if B in Buttons then Inc(ButtonCount);
        ButtonGroupWidth := 0;
        if ButtonCount <> 0 then
          ButtonGroupWidth := ButtonWidth * ButtonCount +
            ButtonSpacing * (ButtonCount - 1);
        ClientWidth := Max(IconTextWidth, ButtonGroupWidth) + HorzMargin * 2;
        ClientHeight := IconTextHeight + ButtonHeight + VertSpacing +
          VertMargin * 2;
        Left := (Screen.Width div 2) - (Width div 2);
        Top := (Screen.Height div 2) - (Height div 2);
        if DlgType <> mtCustom then
    {$IF DEFINED(CLR)}
          Caption := Captions[DlgType] else
          Caption := Application.Title;
        if DlgType <> mtCustom then
    {$ELSE}
          Caption := LoadResString(Captions[DlgType]) else
          Caption := Application.Title;
        if IconID <> nil then
    {$IFEND}
          with TImage.Create(Result) do
          begin
            Name := 'Image';
            Parent := Result;
            Picture.Icon.Handle := LoadIcon(0, IconID);
            SetBounds(HorzMargin, VertMargin, 32, 32);
          end;
        TMessageForm(Result).Message := TLabel.Create(Result);
        with TMessageForm(Result).Message do
        begin
          Name := 'Message';
          Parent := Result;
          WordWrap := True;
          Caption := Msg;
          BoundsRect := TextRect;
          BiDiMode := Result.BiDiMode;
          ALeft := IconTextWidth - TextRect.Right + HorzMargin;
          if UseRightToLeftAlignment then
            ALeft := Result.ClientWidth - ALeft - Width;
          SetBounds(ALeft, VertMargin,
            TextRect.Right, TextRect.Bottom);
        end;
        if mbCancel in Buttons then CancelButton := mbCancel else
          if mbNo in Buttons then CancelButton := mbNo else
            CancelButton := mbOk;
        X := (ClientWidth - ButtonGroupWidth) div 2;
        for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
          if B in Buttons then
          begin
            LButton := TButton.Create(Result);
            with LButton do
            begin
              Name := ButtonNames[B];
              Parent := Result;
    {$IF DEFINED(CLR)}
              Caption := ButtonCaptions[B];
    {$ELSE}
              Caption := LoadResString(ButtonCaptions[B]);
    {$IFEND}
              ModalResult := ModalResults[B];
              if B = DefaultButton then
              begin
                Default := True;
                ActiveControl := LButton;
              end;
              if B = CancelButton then
                Cancel := True;
              SetBounds(X, IconTextHeight + VertMargin + VertSpacing,
                ButtonWidth, ButtonHeight);
              Inc(X, ButtonWidth + ButtonSpacing);
              if B = mbHelp then
                OnClick := TMessageForm(Result).HelpButtonClick;
            end;
          end;
      end;
    end;
    

    由代码可见, CreateMessageDialog只是创建了一个TMessageForm, 然后动态地添加了一些设置. 写到这里或许可以解答一些人的问题: 对话框是不是一个窗口? 答案是:是.

    你还可能会问: 为什么对话框可以停留在那一行代码直到用户操作完毕后再往下执行, 这里就需要了解一下模态窗口的知识:  请参见这篇文章  Delphi ShowModal解析

    转载于:https://www.cnblogs.com/neugls/archive/2011/09/14/2176733.html

    展开全文
  • 一个基于Delphi编写的适用于餐饮行业的销售业绩分析系统模板源码,登录时初始用户名和密码为:matrix ,aaa  功能模块:资料录入、营业分析、餐饮分析、客房分析、输入分析报表等。可作为同类程序的一个设计模板...
  • 摘要:Delphi源码,游戏编程,五子棋,Delphi游戏源码 Delphi五子棋游戏源代码,编写目的:为了让软件开发人员了解该五子棋的开发思想及其过程,并且能发现所存在的问题,及时纠正,同时也有利于本人维护软件,以期使这个...
  • Delphi
  • http代理工具delphi源码

    2016-05-05 16:05:00
    http代理工具delphi源码 以下代码在 DELPHI7+INDY9 下正常编译,只供自己分析研究HTTP用,有兴趣的可以自行修改。---------------------------------------------------...

    http://www.caihongnet.com/content/xingyexinwen/2013/0721/730.html

    http代理工具delphi源码

     

    以下代码在 DELPHI7+INDY9 下正常编译,只供自己分析研究HTTP用,有兴趣的可以自行修改。

    ---------------------------------------------------------------------------------
    -httpproxy.dpr
    ---------------------------------------------------------------------------------

    program HttpProxy;

    uses
    Forms,
    main in 'main.pas' {Main_form};

    {$R *.res}

    begin
    Application.Initialize;
    Application.Title := 'HTTP代理 Ver2.50 ';
    Application.CreateForm(TMain_form, Main_form);
    Application.Run;
    end.


    ----------------------------------------------------------------------------------
    -main.pas
    ----------------------------------------------------------------------------------

    unit main;

    interface

    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs,SyncObjs,ExtCtrls,StdCtrls, ComCtrls, ActnList, ToolWin, ImgList, Menus,
    IdException,IdBaseComponent, IdComponent, IdTCPServer,IdTCPClient,
    IdURI, IdIOHandlerSocket,IdStack,IdGlobal, IdIntercept,
    IdThreadMgr, IdThreadMgrPool, IdAntiFreezeBase,
    IdAntiFreeze, IdLogBase, IdUserAccounts,IdCoderMIME,
    IdAuthentication,IdIOHandler,IdIOHandlerThrottle, IdSocks,
    IdTCPConnection,IdCustomHTTPServer, IdSocketHandle,IdResourceStrings,
    CheckLst, Buttons, Grids, ValEdit;

    type
    TMyServerInterceptLogBase = class;
    TIdOnLogString=procedure (ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string) of object;

    TMyServerInterceptLogBase = class(TIdServerIntercept)
    protected
    FOnLogString:TIdOnLogString;
    FLock: TCriticalSection;
    FLogTime: Boolean;
    FReplaceCRLF: Boolean;
    FActive:boolean;
    public
    procedure Init; override;
    function Accept(AConnection: TComponent): TIdConnectionIntercept; override;
    destructor Destroy;override;
    procedure DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
    procedure LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
    public
    constructor Create(AOwner: TComponent); override;
    published
    property Active: Boolean read FActive write FActive default False;
    property LogTime: Boolean read FLogTime write FLogTime default True;
    property ReplaceCRLF: Boolean read FReplaceCRLF write FReplaceCRLF default true;
    end;

    TMyServerInterceptLogConnection = class(TIdLogBase) //BGO: i just love long class names <g>
    protected
    FServerInterceptLog:TMyServerInterceptLogBase;
    procedure LogReceivedData(const AText: string; const AData: string);override;
    procedure LogSentData(const AText: string; const AData: string); override;
    procedure LogStatus(const AText: string); override;
    function GetConnectionID:string;virtual;

    end;



    TMain_form = class(TForm)
    ProxyServer: TIdTCPServer;
    AntiFreeze: TIdAntiFreeze;
    ThreadPool: TIdThreadMgrPool;
    ImageList: TImageList;
    ActionList: TActionList;
    ToolBar: TToolBar;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    ToolButton4: TToolButton;
    Action_Start: TAction;
    Action_Stop: TAction;
    Action_Quit: TAction;
    StatusBar: TStatusBar;
    UserManager: TIdUserManager;
    ToolButton5: TToolButton;
    ToolButton6: TToolButton;
    Action_LoadServerInfo: TAction;
    Action_LoadAccount: TAction;
    PopupMenu: TPopupMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    ToolButton7: TToolButton;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    ToolButton8: TToolButton;
    Action_Intercept: TAction;
    ToolButton9: TToolButton;
    ToolButton10: TToolButton;
    ToolButton11: TToolButton;
    ToolButton3: TToolButton;
    ToolButton12: TToolButton;
    ToolButton13: TToolButton;
    Action_About: TAction;
    ToolButton14: TToolButton;
    Action_Change: TAction;
    PageControl: TPageControl;
    TabSheet1: TTabSheet;
    ClientQuery: TMemo;
    TabSheet4: TTabSheet;
    ChangeList: TValueListEditor;
    ConnectList: TCheckListBox;
    Splitter1: TSplitter;
    Panel1: TPanel;
    SpeedButton1: TSpeedButton;
    ToolButton15: TToolButton;
    procedure ProxyServerGETCommand(ASender: TIdCommand);
    procedure ProxyServerCONNECTCommand(ASender: TIdCommand);
    procedure Action_StartExecute(Sender: TObject);
    procedure Action_StopExecute(Sender: TObject);
    procedure Action_QuitExecute(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Action_LoadServerInfoExecute(Sender: TObject);
    procedure Action_LoadAccountExecute(Sender: TObject);
    procedure Action_StartUpdate(Sender: TObject);
    procedure Action_StopUpdate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ProxyServerNoCommandHandler(ASender: TIdTCPServer;
    const AData: String; AThread: TIdPeerThread);
    procedure Action_InterceptUpdate(Sender: TObject);
    procedure Action_InterceptExecute(Sender: TObject);
    procedure ProxyServerException(AThread: TIdPeerThread;
    AException: Exception);
    procedure Action_AboutExecute(Sender: TObject);
    procedure Action_ChangeExecute(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    function LoadServerInfo(filename:string):boolean;
    procedure SaveServerInfo(filename:string);
    function LoadUserInfo(filename:string):boolean;
    procedure SaveUserInfo(filename:string);
    function LoadChangeList(filename:string):boolean;
    procedure SaveChangeList(filename:string);
    procedure LogString(ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string);
    end;


    procedure SendResponse(AThread:TIdPeerThread;RespNo:integer;Rawstr:string;Content:string;disconnect:boolean);
    procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
    function Auther(Command:TIdCommand;Headers:TStringList;UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
    procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
    procedure CreateConnect(Command:TIdCommand;Headers:TStringList;var LClient:TIdTCPConnection);
    procedure SendHeaders(LConnection:TIdTCPConnection;Headers:TStringList;Change:boolean);
    procedure SendData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;LSize:integer;Change:boolean);
    procedure TransData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;Change:boolean);
    function ChangeData(S:string):string;

    var
    Main_form: TMain_form;
    ServerInfo,ChangeInfo:TStringList;
    implementation

    {$R *.dfm}

    function TMyServerInterceptLogBase.Accept( AConnection: TComponent): TIdConnectionIntercept;
    begin
    Result:=TMyServerInterceptLogConnection.Create(AConnection);
    TMyServerInterceptLogConnection(Result).FServerInterceptLog:=self;
    TMyServerInterceptLogConnection(Result).LogTime:=FLogTime;
    TMyServerInterceptLogConnection(Result).ReplaceCRLF:=FReplaceCRLF;
    TMyServerInterceptLogConnection(Result).Active:=true;
    TMyServerInterceptLogConnection(Result).FConnection:=AConnection;
    TMyServerInterceptLogConnection(Result).Connect(AConnection);
    end;

    constructor TMyServerInterceptLogBase.Create(Aowner:TComponent);
    begin
    Inherited;
    FReplaceCRLF:=true;
    FLogTime:=true;
    FLock := TCriticalSection.Create;
    end;

    destructor TMyServerInterceptLogBase.Destroy;
    begin
    FreeAndNil(FLock);
    inherited;
    end;

    procedure TMyServerInterceptLogBase.Init;
    begin
    end;

    procedure TMyServerInterceptLogBase.LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
    begin
    // if (Length(AData) > 0) then begin
    FLock.Enter;
    try
    DoLogWriteString(Remote,ConnectTime,Options,AData);
    finally
    FLock.Leave;
    end;
    // end;
    end;

    procedure TMyServerInterceptLogBase.DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
    begin
    if Assigned(FOnLogString) and FActive then begin
    FOnLogString(Self,Remote,ConnectTime,Options,AData);
    end;
    end;

    { TMyServerInterceptLogConnection }

    procedure TMyServerInterceptLogConnection.LogReceivedData(const AText:string;const AData: string);
    begin
    FServerInterceptLog.LogWriteString(GetConnectionID,AText,'R',AData); {Do not translate}
    end;

    procedure TMyServerInterceptLogConnection.LogSentData(const AText: string; const AData: string);
    begin
    FServerInterceptLog.LogWriteString(GetConnectionID,AText,'S',AData); {Do not translate}
    end;

    procedure TMyServerInterceptLogConnection.LogStatus(const AText: string);
    var
    Options:String;
    begin
    if AnsiSameText(Atext,RSLogConnected) then begin
    Options:='C';
    end else if AnsiSameText(AText,RSLogDisconnected) then begin
    Options:='D';
    end else begin
    Options:=AText;
    end;
    FServerInterceptLog.LogWriteString(GetConnectionID,DateTimeToStr(Now),Options,''); {Do not translate}
    end;

    function TMyServerInterceptLogConnection.GetConnectionID:string;
    var
    LSocket: TIdIOHandlerSocket;
    begin
    if (FConnection is TIdTCPConnection) then begin
    LSocket := TIdTCPConnection(FConnection).Socket;
    if (LSocket <> nil) then begin
    if (LSocket.Binding <> nil) then begin
    with LSocket.Binding do begin
    Result := PeerIP + ':' + IntToStr(PeerPort);
    end;
    Exit;
    end;
    end;
    end;
    Result := '0.0.0.0:0';
    end;


    function Auther(Command:TIdCommand; Headers:TStringList;
    UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
    var
    AuthString,AuthUser,AuthPassword:string;
    LConnection:TIdTCPServerConnection;
    LPeerThread:TIdPeerThread;
    begin
    Result:=strtointdef(ServerInfo.Values['UserManager'],0)<=0;
    LPeerThread:=Command.Thread;
    LConnection:=Command.Thread.Connection;

    if Assigned(LPeerThread) and Assigned(LConnection) then begin
    //如果需要代理身份认证
    if LConnection.Connected and (not Result) then begin
    AuthString:=Headers.Values['Proxy-Authorization'];
    Fetch(AuthString,'Basic',true);
    AuthString := TIdDecoderMIME.DecodeString(trim(AuthString));
    //解码用户名和密码
    if length(trim(AuthString))>0 then begin
    Headers.Delete(Headers.IndexOfName('Proxy-Authorization'));
    end;

    AuthUser:=Fetch(AuthString, ':');
    AuthPassword:=AuthString;
    if UserManager.AuthenticateUser(AuthUser,AuthPassword) then begin
    LoginUser:=UserManager.Accounts[AuthUser];
    result:=Assigned(LoginUser);
    end; //if Authentcateuser
    end;
    end;//if usermanager.tag>0

    end;
    function ChangeData(S:string):string;
    var
    temp:integer;
    begin
    result:=s;
    try
    for temp:=0 to ChangeInfo.Count-1 do begin
    result:=StringReplace(result,ChangeInfo.Names[temp],ChangeInfo.ValueFromIndex[temp],[rfReplaceAll]);
    end;
    except
    end;
    end;


    procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
    var
    LIOHandler:TIdIOHandlerThrottle;
    N:integer;
    begin
    if Assigned(Account) and Assigned(LPeer) then begin
    if LPeer.Connected and (LPeer.IOHandler is TIdIOHandlerThrottle) then begin
    N:=strtointdef(Account.Attributes.Values['Speed'],0);
    //设置该用户每连接的流量
    if N<=0 then begin
    N:=strtointdef(ServerInfo.Values['SpeedWithPeer'],0);
    //设置该用户每连接的流量
    end;

    if N>0 then begin
    LIOHandler:=TIdIOHandlerThrottle(LPeer.IOHandler);
    //建立用于控制每连接流量的对象
    LIOHandler.BytesPerSec:=N;
    end;

    end;
    end;

    end;

    procedure CreateConnect(Command:TIdCommand;Headers:TStringList;
    var LClient:TIdTCPConnection);
    var
    LURI: TIdURI;
    LDocument: string;
    ProxyString,ProxyAuth:String;
    LAuth:TIdBasicAuthentication;
    LPeer:TIdTCPConnection;
    LThread:TIdPeerThread;
    LHost:string;
    LVersion:string;
    LSocksInfo:TIdSocksInfo;
    LIOHandler:TIdIOHandlerThrottle;
    begin
    LThread:=Command.Thread;
    LPeer:=Command.Thread.Connection;
    if (not Assigned(Command)) or (not Assigned(LThread))
    or (not Assigned(LPeer)) or (not Assigned(Headers)) then begin
    exit;
    end else begin
    if not (Command.Params.Count=2) then begin
    exit;
    end;
    end;

    if LPeer.Connected and (not LThread.Stopped) then begin
    LClient:=TIdTCPClient.Create(nil);
    LIOHandler:=TIdIOHandlerThrottle.Create(LClient);
    LClient.IOHandler:=TIdIOHandlerSocket.Create(LIOHandler);
    LIOHandler.ChainedHandler:=LClient.IOHandler;
    LClient.IOHandler:=LIOHandler;

    LClient.ReadTimeout:=strtointdef(ServerInfo.Values['ReadTimeOut'],0);
    LClient.ReadTimeout:=iif(LClient.ReadTimeout=-1,0,LClient.ReadTimeout);

    LURI := TIdURI.Create(Command.Params.Strings[0]);
    //建立一个分析URL的对象
    LVersion:=Command.Params.Strings[1];

    if AnsiSameText(Command.CommandHandler.Command,'CONNECT')
    and (LURI.Protocol='') then begin
    //如果是connect命令,并且url中没有http协议字符,则添加后进行分析
    LURI.URI:='HTTP://'+Command.Params.Strings[0];
    end;

    if not AnsiSameText(Command.CommandHandler.Command,'OPTIONS') then begin
    if LURI.Host='' then begin
    exit;
    //如果不是options命令,不能从url中分析出目标主机则认为此请求
    //是无效的http代理请求
    end;
    end else begin
    //如果是options命令,则通过host字段来分析目标主机
    LHost:=Headers.Values['Host'];
    LURI.Host:=Fetch(LHost,':',true);
    LURI.Port:=LHost;
    end;


    try
    TIdTCPClient(LClient).Port := StrToIntDef(LURI.Port, 80);
    //获取请求url中的端口信息
    TIdTCPClient(LClient).Host := LURI.Host;

    LDocument := LURI.Path + LURI.Document + LURI.Params;
    //重建资源路径(使用相对路径的表示方式)
    if LURI.Bookmark<>'' then begin
    LDocument:=LDocument+'#'+LURI.Bookmark;
    end;

    LURI.URI:='';

    ProxyString:=Serverinfo.Values[TIdTCPClient(LClient).Host+':'+
    IntToStr(TIdTCPClient(LClient).Port)];
    //根据系统配置,设置二级代理
    if Length(Trim(ProxyString))>0 then begin
    LURI.URI:=ProxyString;

    if AnsiSameText(LURI.Protocol,'HTTP') then begin
    //如果使用http二级代理
    if not LClient.Connected then begin
    TIdTCPClient(LClient).Port:=StrToIntDef(LURI.Port, 8080);
    TIdTCPClient(LClient).Host := LURI.Host;
    end;
    if LURI.Username<>'' then begin
    //如果二级需要验证身份,则重新修改代理认证字段
    LAuth := TIdBasicAuthentication.Create;
    try
    with LAuth do begin
    Params.Values['Username'] := LURI.Username;
    Params.Values['Password'] := LURI.Password;
    ProxyAuth:= Authentication;
    end;
    if Length(ProxyAuth)>0 then begin
    Headers.Values['Proxy-Authorization']:= ProxyAuth;
    end;
    finally
    LAuth.Free;
    end;
    end;

    end else begin //如果使用socks代理
    LSocksInfo:=LClient.Socket.SocksInfo;
    with LSocksInfo do begin
    IoHandler:=LClient.IOHandler;
    Username:=LURI.Username;
    Password:=LURI.Password;
    if not LClient.Connected then begin
    Host:=LURI.Host;
    Port:=strtointdef(LURI.Port,1080);
    end;
    //设置二级代理的类型 0=无socks代理 1=SOCKS4
    // 2=SOCKS4A 3=SOCKS5
    Version:=TSocksVersion(
    iif(AnsiSameText(LURI.Protocol,'SOCKS4'),1,
    iif(AnsiSameText(LURI.Protocol,'SOCKS4A'),2,
    iif(AnsiSameText(LURI.Protocol,'SOCKS5'),3,0))));
    //根据二级socks代理是否需要身份验证,
    //只有socks5支持身份认证
    Authentication:=TSocksAuthentication(
    iif(trim(UserName)<>'',1,0));
    end;
    end;
    end else begin
    //如果没有定义该目标主机的二级代理,则修改请求命令行
    Headers.Strings[0]:=Command.CommandHandler.Command+' '+
    LDocument+' '+LVersion;
    end; //length(ProxyString)>0

    if Headers.Values['Proxy-Connection']<>'' then begin
    Headers.Delete(Headers.IndexOfName('Proxy-Connection'));
    //删除请求包中的代理标志
    end;

    finally
    FreeAndNil(LURI);
    end;

    try
    TIdTCPClient(LClient).Connect(strtointdef(ServerInfo.Values['ConnectTimeOut'],10000));
    except
    on E:EIdConnectTimeout do begin
    SendResponse(LThread,504,'','连接目标主机超时',true);
    end;
    end;
    end;

    end;

    procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
    begin
    if Assigned(LConnection) and Assigned(Headers) then begin
    if LConnection.Connected then begin
    LConnection.Capture(Headers,'');
    end;
    end;
    end;

    procedure SendData(Athread:TIdPeerThread;LFrom:TIdTCPConnection;
    LTo:TIdTCPConnection;LSize:integer;Change:boolean);
    var
    LContentSize:integer;
    Temp:integer;
    TempStr:string;
    begin
    if not Assigned(AThread) or not Assigned(LFrom) or
    not Assigned(LTo) then begin
    exit;
    end;

    LContentSize:=LSize;

    case Lsize of
    -1:begin
    exit;
    end;
    0:begin
    while (LFrom.Connected) and (LTO.Connected) do begin
    try
    LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
    except

    end;
    if LFrom.InputBuffer.Size>0 then begin
    LFrom.InputBuffer.Seek(0,soFromBeginning);
    try
    LTo.WriteBuffer(LFrom.InputBuffer.memory^,LFrom.InputBuffer.Size);
    finally
    LFrom.InputBuffer.Remove(LFrom.InputBuffer.Size);
    end;
    end;
    LFrom.CheckForGracefulDisconnect(false);
    LTo.CheckForGracefulDisconnect(false);
    end;
    end;
    else begin
    while (LContentSize>0) and (LFrom.Connected) and
    (LTo.Connected) do begin
    try
    LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
    except
    end;

    Temp:=LFrom.InputBuffer.Size;
    if Temp>0 then begin
    try
    if Change then begin
    TempStr:=ChangeData(LFrom.InputBuffer.Extract(Temp));
    LTo.Write(TempStr);
    end else begin
    LTo.WriteBuffer(LFrom.InputBuffer.memory^,Temp);
    LFrom.InputBuffer.Remove(Temp);
    end;
    finally
    Dec(LContentSize,Temp);
    end;
    end;
    LFrom.CheckForGracefulDisconnect(false);
    LTo.CheckForGracefulDisconnect(false);
    end;
    end;
    end;


    end;

    procedure SendHeaders(LConnection:TIdTCPConnection;Headers:TStringList;Change:boolean);
    begin
    if Assigned(LConnection) then begin
    LConnection.OpenWriteBuffer();
    try
    if Change then begin
    Headers.Text:=ChangeData(Headers.Text);
    end;

    LConnection.WriteStrings(Headers);
    finally
    LConnection.CloseWriteBuffer;
    end;

    end;
    end;

    procedure SendResponse(AThread:TIdPeerThread;RespNo:integer;Rawstr:string;
    Content:string;disconnect:boolean);
    var
    LHTTPResponseInfo:TIdHttpResponseInfo;
    Temp:integer;
    begin
    if Assigned(AThread.Connection) and AThread.Connection.Connected and
    not AThread.Stopped then begin
    LHttpResponseInfo:=TIdHttpResponseInfo.Create(AThread.Connection);
    try
    with LHttpResponseInfo do begin
    Server:='HTTP PROXY SERVER Ver 1.0';
    ResponseNo:=RespNo;
    ContentType:='';
    if Length(Content)>0 then begin
    ContentText:=Content;
    end;

    with RawHeaders do begin
    if Server <> '' then begin
    Values['Server'] := Server;
    end;
    if ContentType <> '' then begin
    Values['Content-Type'] := ContentType;
    end;
    if ContentText<>'' then begin
    ContentLength:=Length(ContentText);
    end;
    if ContentLength > 0 then begin
    Values['Content-Length'] := IntToStr(ContentLength);
    end;
    if Length(RawStr)>0 then begin
    Append(Rawstr);
    end;
    end;


    with AThread.Connection do begin
    OpenWriteBuffer;
    try
    WriteLn('HTTP/1.1 ' + IntToStr(ResponseNo) + ' ' +
    ResponseText); {Do not Localize}
    for Temp := 0 to RawHeaders.Count -1 do begin
    WriteLn(RawHeaders[Temp]);
    end;
    WriteLn;
    if ContentLength>0 then begin
    Write(ContentText);
    end;

    finally
    CloseWriteBuffer;
    end;
    end;
    end;
    finally
    LHttpResponseInfo.Free;
    if DisConnect then
    AThread.Connection.Disconnect;
    end;
    end;
    end;

    procedure TransData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;
    LTo:TIdTCPConnection;Change:boolean);
    var
    LClientHandle: TObject;
    LServerHandle: TObject;
    LReadList:TList;
    //LNetData:string;
    begin
    if Assigned(AThread) and Assigned(LFrom) and Assigned(LTo) then begin
    LClientHandle:=TObject(LFrom.Socket.Binding.Handle);
    LServerHandle:=TObject(LTo.Socket.Binding.Handle);
    LReadList:=TList.Create;

    try
    LFrom.CheckForDisconnect(true,true);
    LTo.CheckForDisconnect(true,true);

    while (not AThread.Stopped) and (LFrom.Connected)
    and (LTo.Connected) do begin

    with LReadList do begin
    Clear;
    Add(LClientHandle);
    Add(LServerHandle);

    if GStack.WSSelect(LReadList, nil, nil, IdTimeoutInfinite)
    > 0 then begin

    if IndexOf(LClientHandle) > -1 then begin
    if Change then begin
    LTo.Write(ChangeData(LFrom.CurrentReadBuffer));
    end else begin
    LTo.Write(LFrom.CurrentReadBuffer);
    end;
    end;
    if IndexOf(LServerHandle) > -1 then begin

    LFrom.Write(LTo.CurrentReadBuffer);
    end;
    end else begin
    LFrom.CheckForDisconnect(true,true);
    LTo.CheckForDisconnect(true,true);
    end;
    end; //with
    end;//while do
    finally
    FreeAndNil(LReadList);
    end;
    end //if assigned(athread)...
    end;



    function TMain_form.LoadServerInfo(filename:string):boolean;
    begin
    result:=false;

    if not Assigned(ServerInfo) then begin
    ServerInfo:=TStringList.Create;
    end;

    try
    if Assigned(ServerInfo) and fileexists(filename) then begin
    ServerInfo.Clear;
    ServerInfo.LoadFromFile(filename);

    result:=ServerInfo.Count>1;
    end;
    except
    end;

    end;

    procedure TMain_form.SaveServerInfo(filename:string);
    begin
    //
    if Assigned(ServerInfo) then begin
    if ServerInfo.Count>0 then begin
    try
    ServerInfo.SaveToFile(filename);
    except
    end;
    end;
    end;
    end;

    function TMain_form.LoadUserInfo(filename:string):boolean;
    var
    temp:integer;
    OneUser:TIdUserAccount;
    UsersInfo,OneUserInfo:TStringList;
    begin
    result:=false;
    UsersInfo:=TStringList.Create;
    try
    if Assigned(UsersInfo) and fileexists(filename) then begin
    UsersInfo.LoadFromFile(filename);

    with UserManager do begin
    if UsersInfo.Count>0 then begin
    Accounts.Clear;

    OneUserInfo:=TStringList.Create;

    try
    for temp:=0 to UsersInfo.Count-1 do begin
    OneUserInfo.Clear;
    OneUserInfo.DelimitedText:=UsersInfo.Strings[temp];

    OneUser:=Accounts.Add;
    OneUser.UserName:=OneUserInfo.Values['UserName'];
    OneUser.Password:=OneUserInfo.Values['Password'];
    OneUser.RealName:=OneUserInfo.Values['RealName'];

    OneUserInfo.Delete(OneUserInfo.IndexOfName('UserName'));
    OneUserInfo.Delete(OneUserInfo.IndexOfName('Password'));
    OneUserInfo.Delete(OneUserInfo.IndexOfName('RealName'));
    OneUser.Attributes.Text:=OneUserInfo.Text;
    end;

    result:=true;
    finally
    FreeAndNil(OneUserInfo);
    end;
    end;
    end;
    end;
    finally
    FreeAndNil(UsersInfo);
    end;


    end;

    procedure TMain_form.SaveUserInfo(filename:string);
    var
    OneUser:TIdUserAccount;
    UsersInfo,OneUserInfo:TStringList;
    temp:integer;
    begin
    //
    UsersInfo:=TStringList.Create;
    OneUserInfo:=TStringList.Create;
    try
    try
    UsersInfo.Clear;

    for temp:=0 to UserManager.Accounts.Count-1 do begin
    OneUser:=UserManager.Accounts.Items[temp];

    OneUserInfo.Text:=OneUser.Attributes.Text;
    OneUserInfo.Insert(0,'RealName='+OneUser.RealName);
    OneUserInfo.Insert(0,'Password='+OneUser.Password);
    OneUserInfo.Insert(0,'UserName='+OneUser.UserName);

    UsersInfo.Add(OneUserInfo.DelimitedText);
    end;
    finally
    FreeAndNil(OneUserInfo);
    end;


    UsersInfo.SaveToFile(filename);
    finally
    FreeAndNil(OneUserInfo);
    FreeAndnil(UsersInfo);
    end;

    end;

    procedure TMain_form.SaveChangeList(filename:string);
    begin
    try
    if Assigned(ChangeInfo) then begin
    ChangeInfo.SaveToFile(filename);
    end;
    except
    on e:exception do begin
    end;
    end;
    end;

    function TMain_form.LoadChangeList(filename:string):boolean;
    begin
    result:=false;
    try
    if not Assigned(ChangeInfo) then begin
    ChangeInfo:=TStringList.Create;
    end;

    if Assigned(ChangeInfo) then begin
    ChangeInfo.LoadFromFile(filename);
    ChangeList.Strings.Assign(ChangeInfo);
    result:=true;
    end;
    except
    end;
    end;

    procedure TMain_form.LogString(ASender: TMyServerInterceptLogBase;Remote:string;
    ConnectTime:string;Options:String;AData: String);
    var
    index:integer;
    begin
    try
    if ClientQuery.Lines.Count>strtointdef(ServerInfo.Values['MaxLog'],300) then begin
    ClientQuery.Lines.Clear;
    end;

    Index:=ConnectList.Items.IndexOf(Remote);
    if AnsiSameText(Options,'R') or AnsiSameText(Options,'S') then begin
    ClientQuery.Lines.Add(Remote+#32+Options+#32+inttostr(length(AData))+#32+AData);
    if Index=-1 then begin
    ConnectList.Items.Add(Remote);
    end;
    end else if AnsiSameText(Options,'D') and (Index>-1) then begin
    ConnectList.Items.Delete(Index);
    end;
    except
    end;
    end;



    procedure TMain_form.ProxyServerGETCommand(ASender: TIdCommand);
    var
    LClientHeaders,LServerHeaders:TStringList;
    LContentSize: Integer;
    LClient: TIdTCPClient;
    LPeer:TIdTcpServerConnection;
    LoginUser:TIdUserAccount;
    begin
    ASender.PerformReply:=false;
    //禁止COMMAND执行完毕后自动发送RFC信息
    LPeer:=ASender.Thread.Connection;
    LClient:=Nil;
    //获取保存的到目的主机的连接,用于支持http/1.1协议的在长连接中接收多次请求
    LoginUser:=nil;

    if LPeer.Connected and not ASender.Thread.Stopped then begin
    //检查连接是否中断,线程是否中止
    LClientHeaders:=TStringList.Create;
    //建立接收客户端请求包头变量
    LClientHeaders.NameValueSeparator:=':';

    try
    LClientHeaders.Insert(0,ASender.RawLine);
    //插入客户端请求行
    ReadHeaders(LPeer,LClientHeaders);
    //读取客户端请求头
    //验证客户端身份
    if Auther(ASender,LClientHeaders,Usermanager,LoginUser)then begin
    CreateConnect(ASender,LClientHeaders,TIdTCPConnection(LClient));
    if Assigned(LClient) then begin
    ConnectionSet(LClient,LoginUser);
    if (not ASender.Thread.Stopped) and LClient.Connected then begin
    try
    LClientHeaders.Add('');


    SendHeaders(LClient,LClientHeaders,Action_Change.Checked);
    LContentSize := StrToIntDef(LClientHeaders.Values
    ['Content-Length'], -1) ;
    //判断是否有数据提交给远端
    if LContentSize>0 then begin
    SendData(ASender.Thread,LPeer,LClient,LContentSize,Action_Change.Checked);
    // TransData(ASender.Thread,LPeer,LClient);
    end;
    //发送指定数据到远端

    LServerHeaders:=TStringList.Create;
    //建立接收服务端返回包头变量
    LServerHeaders.NameValueSeparator:=':';
    try
    ReadHeaders(LClient,LServerHeaders);
    LServerHeaders.Add('');
    SendHeaders(LPeer,LServerHeaders,false);

    LContentSize:= StrToIntDef(LServerHeaders.Values
    ['Content-Length'], -1) ;
    //判断是否有返回的数据
    if LContentSize<0 then begin
    LContentSize:=iif(length(LServerHeaders.Values
    ['Content-Type'])>0,0,LContentSize);
    end;

    SendData(ASender.Thread,LClient,LPeer,LContentSize,false);
    //发送返回的数据到客户端
    finally
    LClient.Disconnect;
    FreeAndNil(LServerHeaders);
    end;
    finally
    LClient.Disconnect;
    end;
    end else begin
    LClient.Disconnect;
    end;
    end;
    end else begin
    SendResponse(ASender.Thread,407,
    'Proxy-Authenticate:Basic realm="Http-Proxy Authorization"',
    '', true);
    end;
    finally
    FreeAndNIl(LClient);
    FreeAndNil(LClientHeaders);
    end;
    end;

    end;


    procedure TMain_form.ProxyServerCONNECTCommand(ASender: TIdCommand);
    var
    LClientHeaders:TStringList;
    LClient: TIdTCPClient;
    LPeer:TIdTcpServerConnection;
    LoginUser:TIdUserAccount;
    begin
    ASender.PerformReply:=false;
    //禁止COMMAND执行完毕后自动发送RFC信息
    LPeer:=ASender.Thread.Connection;
    LClient:=nil;
    LoginUser:=nil;

    if LPeer.Connected and not ASender.Thread.Stopped then begin
    //检查连接是否中断,线程是否中止
    LClientHeaders:=TStringList.Create;
    //建立接收客户端请求包头变量
    LClientHeaders.NameValueSeparator:=':';
    try
    LClientHeaders.Insert(0,ASender.RawLine);
    ReadHeaders(LPeer,LClientHeaders); //读取请求包头
    //验证客户端身份
    if Auther(ASender,LClientHeaders,Usermanager,LoginUser) then begin
    CreateConnect(ASender,LClientHeaders,TIdTCPConnection(LClient));
    //建立一个到服务端的客户端对象

    if Assigned(LClient) then begin
    ConnectionSet(LClient,LoginUser); //设置客户端的速率等

    if LClient.Connected then begin
    try
    SendResponse(ASender.thread,200,'','',false);
    TransData(ASender.Thread,LPeer,LClient,Action_Change.Checked);
    //开始在两个连接之间交换数据
    finally
    LClient.Disconnect;
    end;
    end;
    end;
    end;
    finally
    FreeAndNil(LClientHeaders);
    FreeAndNIl(LClient);
    end;

    end;



    end;

    procedure TMain_form.Action_StartExecute(Sender: TObject);
    begin
    if Action_LoadServerInfo.Execute then begin
    try
    ProxyServer.Active:=true;
    except
    end;

    end;
    end;

    procedure TMain_form.Action_StopExecute(Sender: TObject);
    begin
    if (not Action_Stop.Checked ) and ProxyServer.Active then begin
    try
    ProxyServer.Active:=false;
    finally

    end;
    end;
    end;

    procedure TMain_form.Action_QuitExecute(Sender: TObject);
    begin
    try
    if ProxyServer.Active then begin
    if Application.MessageBox('退出前需要停止服务','注意',
    MB_OKCANCEL)=ID_OK then begin
    Action_Stop.Execute;
    end else begin
    exit;
    end;
    end;
    finally;
    close;
    end;
    end;

    procedure TMain_form.FormCloseQuery(Sender: TObject;
    var CanClose: Boolean);
    begin
    if ProxyServer.Active then
    Action_Stop.Execute;

    CanClose:=Application.MessageBox('你确定推出该程序么?','关闭',
    MB_OKCANCEL)=ID_OK;
    end;

    procedure TMain_form.Action_LoadServerInfoExecute(Sender: TObject);
    var
    ServerInfoName:string;
    temp:integer;
    BindingList:TStringList;
    LSockHandler:TIdSocketHandle;
    begin
    if not ProxyServer.Active then begin
    try
    ServerInfoName:=ExtractFilePath(Application.ExeName)+'ServerInfo.txt';
    if LoadServerInfo(ServerInfoName) then begin
    with ProxyServer do begin
    DefaultPort:=strtointdef(ServerInfo.Values['DefaultPort'],8080);
    MaxConnections:=strtointdef(ServerInfo.Values['MaxConnections'],0);
    UserManager.Tag:=strtointdef(ServerInfo.Values['UserManager'],0);

    for temp:=0 to ProxyServer.CommandHandlers.Count-1 do begin
    CommandHandlers.Items[temp].Enabled:=strtointdef(ServerInfo.
    Values[CommandHandlers.
    Items[temp].Name],1)>0;
    end;

    DefaultPort:=strtointdef(ServerInfo.Values['DefaultPort'],8080);
    BindingList:=TStringList.Create;
    BindingList.NameValueSeparator:=':';
    BindingList.DelimitedText:=ServerInfo.Values['HttpProxyBindings'];
    try
    Bindings.Clear;
    for temp:=0 to BindingList.Count-1 do begin
    LSockHandler:=Bindings.Add;
    LSockHandler.IP:=BindingList.Names[temp];
    LSockHandler.Port:=strtointdef(BindingList.
    ValueFromIndex[temp],DefaultPort);
    end;

    finally
    FreeAndNil(BindingList);
    end;

    end;
    end;
    except
    end;
    end;
    end;

    procedure TMain_form.Action_LoadAccountExecute(Sender: TObject);
    var
    UserInfoName:string;
    begin
    if UserManager.Tag=1 then begin
    UserInfoName:=ExtractFilePath(Application.ExeName)+'UserInfo.txt';

    try
    UserManager.Tag:=iif(LoadUserInfo(UserInfoName),1,0);
    except
    end;
    end;

    end;

    procedure TMain_form.Action_StartUpdate(Sender: TObject);
    begin
    if Sender is TAction then begin
    TAction(Sender).Enabled:=not ProxyServer.Active;
    end;
    end;

    procedure TMain_form.Action_StopUpdate(Sender: TObject);
    begin
    Action_Stop.Enabled:=ProxyServer.Active;
    end;


    procedure TMain_form.FormCreate(Sender: TObject);
    var
    ServerIntercept:TMyServerInterceptLogBase;
    begin
    if Action_LoadServerInfo.Execute then begin
    Action_LoadAccount.Execute;
    end;

    try
    ServerIntercept:=TMyServerInterceptLogBase.Create(ProxyServer);
    ServerIntercept.ReplaceCRLF:=false;
    ServerIntercept.FOnLogString:=LogString;
    ProxyServer.Intercept:=ServerIntercept;
    except
    end;

    try
    LoadChangeList(ExtractFilePath(Application.ExeName)+'ChangeList.txt');
    except
    end;
    end;

    procedure TMain_form.ProxyServerNoCommandHandler(ASender: TIdTCPServer;
    const AData: String; AThread: TIdPeerThread);
    begin
    SendResponse(AThread,501,'','',true);
    //501 未实现(Not Implemented)
    //服务器无法提供对请求中所要求功能的支持。
    //如果服务器无法识别请求方法就会回
    //应此状态代码,这意味着不能回应请求所要求的任何资源。

    end;

    procedure TMain_form.Action_InterceptUpdate(Sender: TObject);
    begin
    Action_Intercept.Enabled:= Assigned(ProxyServer.Intercept) and
    (ProxyServer.Intercept is TMyServerInterceptLogBase);

    end;

    procedure TMain_form.Action_InterceptExecute(Sender: TObject);
    var
    view:boolean;
    begin
    try
    View:=TMyServerInterceptLogBase(ProxyServer.Intercept).Active;
    TMyServerInterceptLogBase(ProxyServer.Intercept).Active:=not View;
    if not TMyServerInterceptLogBase(ProxyServer.Intercept).Active then begin
    ConnectList.Clear;
    end;
    toolbutton8.Down:=not View;
    ;
    except
    Action_Intercept.Enabled:=false;
    toolbutton8.Down:=false;
    end;

    end;

    procedure TMain_form.ProxyServerException(AThread: TIdPeerThread;
    AException: Exception);
    begin
    { if Assigned(AException) then begin
    SendResponse(AThread,500,'','',true);
    // 500 服务器内部错误(Internal Server Error)
    //服务器碰到了意外情况,使其无法继续回应请求
    end;
    }
    end;

    procedure TMain_form.Action_AboutExecute(Sender: TObject);
    var
    AboutStr:string;
    begin
    AboutStr:=' 迷你HTTP 代理服务器 '+EOL+EOL+
    ' Ver 2.50 '+EOL+EOL+
    ' Copyright 2005-2008 '+EOL+EOL+
    ' Email:qlj@yeah.net ';
    Application.MessageBox(Pchar(ABoutStr),'关于',Mb_Ok);
    end;

    procedure TMain_form.Action_ChangeExecute(Sender: TObject);
    begin
    try
    Action_Change.Checked:=not Action_Change.Checked;
    toolbutton14.Down:=Action_Change.Checked;
    except
    toolbutton14.Down:=false;
    end;
    end;

    procedure TMain_form.SpeedButton1Click(Sender: TObject);
    begin
    try
    if Assigned(ChangeInfo) then begin
    ChangeInfo.Assign(ChangeList.Strings);
    end;

    SaveChangeList(ExtractFilePath(Application.ExeName)+'ChangeList.txt');
    except
    end;
    end;

    end.




    ----------------------------------------------------------------------------------
    - Main.dfm
    ----------------------------------------------------------------------------------

    object Main_form: TMain_form
    Left = 213
    Top = 131
    Width = 564
    Height = 449
    Caption = #36855#20320'HTTP'#20195#29702' Ver 2.50'
    Color = clBtnFace
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = #23435#20307
    Font.Style = []
    Icon.Data = {
    0000010001002020100000000000E80200001600000028000000200000004000
    0000010004000000000080020000000000000000000000000000000000000000
    000000008000008000000080800080000000800080008080000080808000C0C0
    C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF009999
    99999999999999999999999999999FFFFFFFFFFFFF88888888888FFFFFF997FF
    FFFFFFFF888888888888888FFFF9977FFFFFFFF8444C444888888888FFF99777
    FFFFFF4444444444488888888FF997777FFF44444C4C4C4C4C48888888F99777
    77F44444443444444444888888F99777774C444C433C4C4C4C4C488888899777
    74444444C334C444C444C48888899777744C4C4C433C4C4C4C4C4C8888899777
    444444C43334CCC4C4C4C44888899777444C4C43333C4C4C4C4C4C3888899774
    4444C4433333CCCCC4CCC433888997744C4C4C4333333C4C4C4C4C3388899774
    4444C43333333CCCCCCCC43388899774444C4C333333CC4CCC4C4C3388899774
    4444C433333CCCCCCCC33333888997744C4C4C334C4C4CCCCCC3333388899774
    44444433CCCC3CCCCCC3333388F99777444C4C433C433C4CCC4C333888F99777
    4444343333333CCCCCCCC4C88FF99777744C333333333C4C4C433C88FFF99777
    7444333333333CCCCCC3348FFFF99777774C333333333C4C3C433FFFFFF99777
    7774333333C333CC3433FFFFFFF9977777774333334C333C4C377FFFFFF99777
    77777744433444C4477777FFFFF99777777777774C4C4C477777777FFFF99777
    777777777777777777777777FFF997777777777777777777777777777FF99777
    77777777777777777777777777F9999999999999999999999999999999990000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    000000000000000000000000000000000000000000000000000000000000}
    OldCreateOrder = False
    Position = poScreenCenter
    OnCloseQuery = FormCloseQuery
    OnCreate = FormCreate
    PixelsPerInch = 96
    TextHeight = 12
    object ToolBar: TToolBar
    Left = 0
    Top = 0
    Width = 556
    Height = 53
    AutoSize = True
    ButtonHeight = 51
    ButtonWidth = 61
    Ctl3D = False
    Flat = True
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = #23435#20307
    Font.Style = []
    Images = ImageList
    Indent = 3
    ParentFont = False
    ShowCaptions = True
    TabOrder = 0
    Transparent = True
    object ToolButton1: TToolButton
    Left = 3
    Top = 0
    Action = Action_Start
    AutoSize = True
    end
    object ToolButton5: TToolButton
    Left = 56
    Top = 0
    Width = 8
    ImageIndex = 6
    Style = tbsSeparator
    end
    object ToolButton2: TToolButton
    Left = 64
    Top = 0
    Action = Action_Stop
    AllowAllUp = True
    AutoSize = True
    end
    object ToolButton6: TToolButton
    Left = 123
    Top = 0
    Width = 8
    ImageIndex = 6
    Style = tbsSeparator
    end
    object ToolButton3: TToolButton
    Left = 131
    Top = 0
    Action = Action_LoadServerInfo
    end
    object ToolButton7: TToolButton
    Left = 192
    Top = 0
    Width = 8
    Caption = 'ToolButton7'
    ImageIndex = 7
    Style = tbsSeparator
    end
    object ToolButton10: TToolButton
    Left = 200
    Top = 0
    Action = Action_LoadAccount
    end
    object ToolButton11: TToolButton
    Left = 261
    Top = 0
    Width = 8
    Caption = 'ToolButton11'
    ImageIndex = 5
    Style = tbsSeparator
    end
    object ToolButton8: TToolButton
    Left = 269
    Top = 0
    Action = Action_Intercept
    end
    object ToolButton15: TToolButton
    Left = 330
    Top = 0
    Width = 8
    Caption = 'ToolButton15'
    ImageIndex = 7
    Style = tbsSeparator
    end
    object ToolButton14: TToolButton
    Left = 338
    Top = 0
    Action = Action_Change
    end
    object ToolButton9: TToolButton
    Left = 399
    Top = 0
    Width = 8
    Caption = 'ToolButton9'
    ImageIndex = 6
    Style = tbsSeparator
    end
    object ToolButton13: TToolButton
    Left = 407
    Top = 0
    Action = Action_About
    end
    object ToolButton12: TToolButton
    Left = 468
    Top = 0
    Width = 8
    Caption = 'ToolButton12'
    ImageIndex = 6
    Style = tbsSeparator
    end
    object ToolButton4: TToolButton
    Left = 476
    Top = 0
    Action = Action_Quit
    AutoSize = True
    end
    end
    object StatusBar: TStatusBar
    Left = 0
    Top = 403
    Width = 556
    Height = 19
    AutoHint = True
    Panels = <>
    end
    object PageControl: TPageControl
    Left = 0
    Top = 53
    Width = 556
    Height = 350
    ActivePage = TabSheet1
    Align = alClient
    Images = ImageList
    Style = tsFlatButtons
    TabOrder = 2
    object TabSheet1: TTabSheet
    Caption = #30417#35270
    ImageIndex = 3
    object Splitter1: TSplitter
    Left = 121
    Top = 0
    Height = 302
    end
    object ClientQuery: TMemo
    Left = 124
    Top = 0
    Width = 424
    Height = 302
    Hint = #36827#20986#30340#25968#25454#21253' R= '#23458#25143#31471'to'#26381#21153#31471' S= '#26381#21153#31471'TO'#23458#25143#31471
    Align = alClient
    Ctl3D = False
    ParentCtl3D = False
    ScrollBars = ssBoth
    TabOrder = 0
    WordWrap = False
    end
    object ConnectList: TCheckListBox
    Left = 0
    Top = 0
    Width = 121
    Height = 302
    Hint = #25152#26377#24403#21069#36830#25509
    Align = alLeft
    Ctl3D = False
    ItemHeight = 12
    ParentCtl3D = False
    TabOrder = 1
    end
    end
    object TabSheet4: TTabSheet
    Caption = #31713#25913
    ImageIndex = 7
    object ChangeList: TValueListEditor
    Left = 0
    Top = 0
    Width = 530
    Height = 272
    Hint = #24314#35758#22343#20026#23383#31526#20018#65292#20540#20013#19981#33021#26377'='#21495
    Align = alClient
    Ctl3D = False
    KeyOptions = [keyEdit, keyAdd, keyDelete, keyUnique]
    ParentCtl3D = False
    TabOrder = 0
    TitleCaptions.Strings = (
    #21407#20540
    #20462#25913#20540)
    ColWidths = (
    261
    265)
    end
    object Panel1: TPanel
    Left = 0
    Top = 272
    Width = 530
    Height = 30
    Align = alBottom
    BevelOuter = bvNone
    TabOrder = 1
    object SpeedButton1: TSpeedButton
    Left = 232
    Top = 0
    Width = 73
    Height = 30
    Caption = #24212#29992#20445#23384
    Flat = True
    OnClick = SpeedButton1Click
    end
    end
    end
    end
    object ProxyServer: TIdTCPServer
    Bindings = <>
    CommandHandlers = <
    item
    CmdDelimiter = ' '
    Command = 'OPTIONS'
    Disconnect = True
    Name = 'HTTP_OPTIONS'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'GET'
    Disconnect = True
    Name = 'HTTP_GET'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'HEAD'
    Disconnect = True
    Name = 'HTTP_HEAD'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'POST'
    Disconnect = True
    Name = 'HTTP_POST'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'PUT'
    Disconnect = True
    Name = 'HTTP_PUT'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'DELETE'
    Disconnect = True
    Name = 'HTTP_DELETE'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'TRACE'
    Disconnect = True
    Name = 'HTTP_TRACE'
    OnCommand = ProxyServerGETCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end
    item
    CmdDelimiter = ' '
    Command = 'CONNECT'
    Disconnect = True
    Name = 'HTTP_CONNECT'
    OnCommand = ProxyServerCONNECTCommand
    ParamDelimiter = ' '
    ReplyExceptionCode = 0
    ReplyNormal.NumericCode = 0
    Tag = 0
    end>
    DefaultPort = 8080
    Greeting.NumericCode = 0
    MaxConnectionReply.NumericCode = 0
    MaxConnectionReply.Text.Strings = (
    'HTTP/1.0 503 Service Unavailable'
    'Connection: close'
    'Content-Type: text/html'
    ''
    '<html>'
    ' <head>'
    ' 503 '#36798#21040#26368#22823#36830#25509#25968#65281
    ' </head>'
    '</html>')
    OnException = ProxyServerException
    OnNoCommandHandler = ProxyServerNoCommandHandler
    ReplyExceptionCode = 0
    ReplyTexts = <>
    ReplyUnknownCommand.NumericCode = 0
    Left = 16
    Top = 279
    end
    object AntiFreeze: TIdAntiFreeze
    Left = 80
    Top = 279
    end
    object ThreadPool: TIdThreadMgrPool
    PoolSize = 10
    Left = 48
    Top = 279
    end
    object ImageList: TImageList
    Height = 32
    Width = 32
    Left = 49
    Top = 246
    Bitmap = {000000000000}
    end
    object ActionList: TActionList
    Images = ImageList
    Left = 17
    Top = 246
    object Action_Start: TAction
    Caption = #21551'[&R]'#21160
    Hint = #21551#21160#20195#29702#26381#21153
    ImageIndex = 0
    OnExecute = Action_StartExecute
    OnUpdate = Action_StartUpdate
    end
    object Action_Stop: TAction
    Caption = #20572'[&S]'#27490' '
    Hint = #20851#38381#20195#29702#26381#21153
    ImageIndex = 1
    OnExecute = Action_StopExecute
    OnUpdate = Action_StopUpdate
    end
    object Action_Quit: TAction
    Caption = #36864'[&Q]'#20986' '
    Hint = #36864#20986#20195#29702#31243#24207
    ImageIndex = 5
    OnExecute = Action_QuitExecute
    end
    object Action_LoadServerInfo: TAction
    Caption = #31995'[&O]'#32479
    Hint = #35835#21462#24212#29992#31995#32479#37197#32622
    ImageIndex = 2
    OnExecute = Action_LoadServerInfoExecute
    OnUpdate = Action_StartUpdate
    end
    object Action_LoadAccount: TAction
    Caption = #24080'[&U]'#25143
    Hint = #35835#21462#24212#29992#29992#25143#37197#32622
    ImageIndex = 4
    OnExecute = Action_LoadAccountExecute
    OnUpdate = Action_StartUpdate
    end
    object Action_Intercept: TAction
    Caption = #30417'[&V]'#35270' '
    Hint = #30417#35270#25968#25454#36827#20986
    ImageIndex = 3
    OnExecute = Action_InterceptExecute
    OnUpdate = Action_InterceptUpdate
    end
    object Action_About: TAction
    Caption = #20851'[&A]'#20110
    Hint = #36855#20320#20195#29702#31243#24207
    ImageIndex = 6
    OnExecute = Action_AboutExecute
    end
    object Action_Change: TAction
    Caption = #31713'[&C]'#25913
    Hint = #31713#25913#36755#20986#30340#25968#25454#21253
    ImageIndex = 7
    OnExecute = Action_ChangeExecute
    end
    end
    object UserManager: TIdUserManager
    Accounts = <>
    CaseSensitiveUsernames = False
    CaseSensitivePasswords = False
    Left = 106
    Top = 280
    end
    object PopupMenu: TPopupMenu
    Images = ImageList
    Left = 82
    Top = 246
    object N5: TMenuItem
    Action = Action_Start
    SubMenuImages = ImageList
    end
    object N1: TMenuItem
    Action = Action_Stop
    SubMenuImages = ImageList
    end
    object N2: TMenuItem
    Caption = '-'
    ImageIndex = 2
    end
    object N3: TMenuItem
    Action = Action_LoadServerInfo
    SubMenuImages = ImageList
    end
    object N4: TMenuItem
    Action = Action_LoadAccount
    SubMenuImages = ImageList
    end
    object N6: TMenuItem
    Caption = '-'
    end
    object N7: TMenuItem
    Action = Action_Quit
    SubMenuImages = ImageList
    end
    end
    end


    ---------------------------------------------------------------------------------
    - Userinfo.txt
    ---------------------------------------------------------------------------------
    UserName=test,Password=test,Speed=102400


    ---------------------------------------------------------------------------------
    - ServerInfo.txt
    ---------------------------------------------------------------------------------
    #默认开放的代理端口,如果没有在bindings中指定需要提供代理的网段及端口,则默认在所有网段的defaultport上提供服务
    DefaultPort=8888
    #指定提供HTTP代理服务的接口ip及端口,用","分隔多个接口如:127.0.0.1:8080,127.0.0.1:8888,192.168.1.2:8080
    HttpProxyBindings=0.0.0.0:8080
    #端口映射服务所需要开放的接口及端口
    MapBindings=127.0.0.1:9000
    #代理服务所允许的最大连接数量,不是客户数,一个ie打开时有时侯可能同时开启4个连接,主要用于控制代理服务器的最大处理能力
    MaxConnections=0
    #控制是否使用代理认证,如果=1,则使用userinfo中的信息来人正客户端
    UserManager=0
    #设置代理服务器连接到目标服务器所允许的最大时间,避免一直连接,而无法中断该线程
    ConnectTimeOut=10000
    #设置读取数据的最大等待时间
    ReadTimeOut=10000
    #设置默认情况下每个连接的最大流量,1048576=1024*1024=1Mb,如果需要对某客户端控制,则需要在userinfo中对该用户配置
    SpeedWithPeer=1048576
    #最大日志行数
    MaxLog=10000
    #设置所允许的命令方法,常用的有get,post,head,options,允许http隧道功能的话需要开放connect
    HTTP_OPTIONS=1
    HTTP_GET=1
    HTTP_HEAD=1
    HTTP_POST=1
    HTTP_PUT=1
    HTTP_DELETE=1
    HTTP_TRACE=1
    HTTP_CONNECT=1

    ---------------------------------------------------------------------------------
    - ChangeList.txt
    ---------------------------------------------------------------------------------
    6C8A4B3A018BE81FEA0D686B5BADE6B2=4D1DEEF37B4F0FDCBBBA76090A363611
    E7BA34301BA410175BCAA875802310D6=4D1DEEF37B4F0FDCBBBA76090A363611  

    (责任编辑:admin)以上内容为彩虹远程控制软件官方网站为您搜集整理

    转载于:https://www.cnblogs.com/delphi-xe5/p/5462280.html

    展开全文
  • 分析IP封包,拦截IP包(delphi源码)

    热门讨论 2008-12-07 15:22:09
    分析封包的代码,有能力的人拿来学学不错的。
  • 广电行业GIS系统 delphi源码。系统功能分七大类,1. 网络构建: l 新建设备和线路、 l 编辑线路、 l 设备及其间相互关系; 2. 网络应用: l 设备、线路的静态及动态属性、 l 各种专业分析、 l 设备的查询统计...
  • 录音小工具delphi源码

    2011-01-07 13:33:22
    delphi编写的录音小工具,封装了,使用很简单,其中的录音文件分析单元是从网上找的,现在分享给大家
  • 网上流传的 word批量处理工具...各类控件,主要实现代码写的挺不精炼的,分析这么的实例,纯属浪费时间。
  • Delphi/Access共同实现的超市综合管理系统,比较完整,带有前台和后台管理,功能上有点类似进销存,但比进销存功能更多,包括了人员管理、来货登记、库存盘点、入库验收、库存预警、计量单位、购进退回、毛利分析、...
  • 此款源码功能不少,大家下载后要慢慢的体验其中的代码。下图是编译好的程序:
  • Delphi源代码分析的作者周爱民有着十余年的软件开发、团队建设经验。目前主要从事软件工程、体系架构和语言基础方面的研究与实践。他的 《Delphi源代码分析》一书曾被誉为“Delphi领域精品著作”。这就是这本书的...
  • Delphi源码分析抽取工具,目前能够构建代码结构树,同时应部分网友要求,增加了类名、过程/函数名等列表功能
  • FPGA+CY7C68013A+delphi7逻辑分析仪开源项目全套源码
  • Delphi版的学校学生信息管理系统,使用SQL Server 2000数据库,在配置数据库时,步骤如下: 1.将数据库复制硬盘上 确保您的机器上安装了SQL Server2000或以上的版本,将本示例的数据库文件连同文件夹“college”...
  • Delphi 毕业论文源码:PEDump文件分析器含文档,文档包括任务书.doc,论文正文.doc,论文目录.doc,附录.doc。很多时候我们需要对自己或者已有的PE文件作一个分析,以便改进或者研究,由于PE文件是计算机中最重要,...
  • delphi dbchar控件 利用图表分析产品价格行情实例源码
  • 只有亲自动手分析了病毒感染过程,发现病毒还好只是修改了ESP,将病毒本体附加在执行文件后,另外对某些HTML文件会附加含一个病毒网页的IFRAME,讨厌的是病毒还会感染压缩包里的执行文件和网页。自己用Delphi写了一...

空空如也

空空如也

1 2 3 4 5 ... 14
收藏数 277
精华内容 110
关键字:

delphi源码分析