delphi 仿照世界之窗浏览器，滑动鼠标关闭主程序

unit umousemove;

interface

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

type
    Tfrommousemove = class(TForm)
        Image1: TImage;
        Image2: TImage;
        procedure FormCreate(Sender: TObject);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
        procedure FormShow(Sender: TObject);
        procedure Image2MouseDown(Sender: TObject; Button:
            TMouseButton; Shift: TShiftState; X, Y: Integer);
        procedure Image2MouseMove(Sender: TObject; Shift: TShiftState;
            X, Y: Integer);
        procedure Image2MouseUp(Sender: TObject; Button: TMouseButton;
            Shift: TShiftState; X, Y: Integer);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

type
    Rvaluepos = record
        x, y: double;
        a, b, c, c_Cos, maxposx: double;
        tangle: Double;
    end;

var
    frommousemove: Tfrommousemove;
    First, Mdown: Boolean;
    ox, oy, ox1, oy1: Integer;
    valuepos: array of Rvaluepos;
    len: Integer;
    Maxtangle: double;
    errstr: string;
    gButton: TMouseButton;
    gShift: TShiftState;
    gX, gY: Integer;
    rslt: Boolean;

implementation

{$R *.dfm}

procedure Tfrommousemove.FormClose(Sender: TObject; var Action:
    TCloseAction);
begin
    SetLength(valuepos, 0);
end;

procedure Tfrommousemove.FormCreate(Sender: TObject);
begin
    Mdown := False;
    Tag := 0;
    Self.BorderStyle := bsNone;
    self.AlphaBlend := true; //透明
    self.AlphaBlendValue := 240; //透明度
    self.TransparentColor := true; //透明颜色
    Image1.SetBounds((Self.Left + self.Width) div 2, (Self.Top + self.Height)
        div 2, Image1.Width, Image1.Height);
    Image1.Visible := False;

end;

procedure Tfrommousemove.FormShow(Sender: TObject);
var
    p: TPoint;
begin
    GetCursorPos(p);
    gX := p.X;
    gY := p.Y;
    gShift := [ssRight];
//    i.FormMouseDown(self, mbRight, gShift, gx, gY);
end;

procedure Tfrommousemove.Image2MouseDown(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    if ssRight in Shift then
    begin


        Image2.Canvas.Pen.Mode := pmNotXor;
        Image2.Canvas.Pen.Color := clblue;
        Image2.Canvas.Pen.Style := psSolid;
        Image2.Canvas.Pen.Width := 2;

        Mdown := true;
        First := true;
        OX := X;
        OY := Y;

        SetLength(valuepos, 0);
        len := 1;
        SetLength(valuepos, len);
        valuepos[0].X := X;
        valuepos[0].Y := Y;
        valuepos[0].a := 0.0;
        valuepos[0].b := 0.0;
        valuepos[0].c := 0.0;
        valuepos[0].tangle := 0.0;
        valuepos[0].c_cos := 0.0;
        valuepos[0].maxposx := X;
        Maxtangle := 0.0;
    end;
end;

procedure Tfrommousemove.Image2MouseMove(Sender: TObject; Shift:
    TShiftState; X, Y: Integer);
var
    c_cos: double;
begin
    if not (ssRight in Shift) then
    begin
        exit;
    end;
    c_cos := 0.0;

    if Mdown then
    begin
        if not First then
        begin
            Image2.Canvas.MoveTo(OX1, OY1);
            Image2.Canvas.LineTo(X, Y);
        end
        else
        begin
            Image2.Canvas.MoveTo(ox, oy);
            Image2.Canvas.LineTo(X, Y);
        end;
        OX1 := X;
        OY1 := Y;
        First := False;
    end;
    if len < 1 then
    begin
        exit;
    end;
    if (X - valuepos[len - 1].X) * (X - valuepos[len - 1].X) + (Y -
        valuepos[len - 1].Y) * (Y - valuepos[len - 1].Y) > 4 then
    begin
        Inc(len);
        SetLength(valuepos, len);
        if valuepos[len - 2].maxposx < X then
        begin
            valuepos[len - 1].maxposx := X;
        end
        else
        begin
            valuepos[len - 1].maxposx := valuepos[len - 2].maxposx;
        end;
        valuepos[len - 1].X := X;
        valuepos[len - 1].Y := Y;

        if len < 3 then
        begin
            try

                valuepos[len - 1].a := Sqrt(1.0 * (X - valuepos[len -
                    1].X) * (X - valuepos[len - 1].X) + 1.0 * (Y -
                    valuepos[len - 1].Y) * (Y - valuepos[len - 1].Y));
                valuepos[len - 1].b := 0.0;
                valuepos[len - 1].c := 0.0;
                valuepos[len - 1].tangle := 0.0;
                valuepos[len - 1].c_cos := 0.0;
                Maxtangle := 0.0;
            except
                on E: Exception do
                begin
                    errstr := e.Message;
                end;
            end;

        end
        else
        begin
            try

                valuepos[len - 1].a := Sqrt((valuepos[len - 2].X -
                    valuepos[0].X) * (valuepos[len - 2].X - valuepos[0].X)
                    + (valuepos[len - 2].Y - valuepos[0].Y) * (valuepos
                    [len - 2].Y - valuepos[0].Y));
                valuepos[len - 1].b := Sqrt((valuepos[len - 1].X -
                    valuepos[len - 2].X) * (valuepos[len - 1].X -
                    valuepos[len - 2].X) + (valuepos[len - 1].Y -
                    valuepos[len - 2].Y) * (valuepos[len - 1].Y -
                    valuepos[len - 2].Y));
                valuepos[len - 1].c := Sqrt((valuepos[len - 1].X -
                    valuepos[0].X) * (valuepos[len - 1].X - valuepos[0].X)
                    + (valuepos[len - 1].Y - valuepos[0].Y) * (valuepos
                    [len - 1].Y - valuepos[0].Y));
                c_cos := (valuepos[len - 1].a * valuepos[len - 1].a +
                    valuepos[len - 1].b * valuepos[len - 1].b -
                    valuepos[len - 1].c * valuepos[len - 1].c) / (2.0
                    * valuepos[len - 1].a * valuepos[len - 1].b);
            except
                on E: Exception do
                begin
                    errstr := e.Message;
                end;
            end;

            try

                valuepos[len - 1].c_cos := c_cos;
                valuepos[len - 1].tangle := ArcCos(c_cos * 1.0) *
                    180.0 / 3.14;
            except
                on E: Exception do
                begin
                    errstr := e.Message;
                end;

            end;

            if (valuepos[len - 1].tangle > Maxtangle) and (valuepos[len
                - 1].tangle < 100) then
            begin
                Maxtangle := valuepos[len - 1].tangle;
            end;

            if (Maxtangle > 15) and (valuepos[len - 1].maxposx <=
                valuepos[len - 1].X) then
            begin
                Image1.Visible := True;
            end

        end;

    end;
end;

procedure Tfrommousemove.Image2MouseUp(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    Mdown := False;
    OX := 0;
    OY := 0;
    OX1 := 0;
    OY1 := 0;

    if len < 1 then
    begin
        exit;
    end;
    if (Maxtangle > 15) and (valuepos[len - 1].maxposx <= valuepos[len
        - 1].X) then
    begin

        len := 0;
        SetLength(valuepos, 0);
        Maxtangle := 0;
        rslt := True;
        Self.Close;

    end
    else
    begin
        len := 0;
        SetLength(valuepos, 0);
        Maxtangle := 0;
        rslt := False;
        Self.Close;
    end;
end;

end.

//主程序处理：

unit XJMAIN;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics,
    Controls, Forms, Dialogs, RzGroupBar, ImgList, Menus, StdCtrls,
    ExtCtrls, RzBorder, RzTabs, UcreateTableTool, sqlstrtodelphi,
    UJBZCodeTool, Ugetzw, unit6, UNat, ComCtrls, AppEvnts, umousemove,
    UbillCode;

type
    Tfrmxjmain = class(TForm)
        RzGroupBar1: TRzGroupBar;
        RzGroup1: TRzGroup;
        RzGroup2: TRzGroup;
        RzGroup3: TRzGroup;
        il1: TImageList;
        il2: TImageList;
        RzGroup4: TRzGroup;
        pgc1: TRzPageControl;
        TabSheet1: TRzTabSheet;
        XJStatusbar: TStatusBar;
        ApplicationEventsXJ: TApplicationEvents;
        MainMenu1: TMainMenu;
        N1: TMenuItem;
        N2: TMenuItem;
        procedure RzGroup1Items0Click(Sender: TObject);
        procedure RzGroup1Items1Click(Sender: TObject);
        procedure FormClose(Sender: TObject; var Action: TCloseAction);
        procedure RzGroup1Items2Click(Sender: TObject);
        procedure pgc1Close(Sender: TObject; var AllowClose: Boolean);
        procedure RzGroup1Items3Click(Sender: TObject);
        procedure RzGroup1Items5Click(Sender: TObject);
        procedure RzGroup1Items4Click(Sender: TObject);
        procedure RzGroup1Items6Click(Sender: TObject);
        procedure pgc1MouseDown(Sender: TObject; Button: TMouseButton;
            Shift: TShiftState; X, Y: Integer);
        procedure ApplicationEventsXJMessage(var Msg: tagMSG; var
            Handled: Boolean);
        procedure FormCreate(Sender: TObject);
        procedure freepage(index: integer);
        procedure N2Click(Sender: TObject);
        procedure RzGroup2Items0Click(Sender: TObject);
    procedure ApplicationEventsXJActionExecute(Action: TBasicAction;
      var Handled: Boolean);
    private
    { Private declarations }
    public
    { Public declarations }
        procedure createForm(formname: string);
    end;

var
    frmxjmain: Tfrmxjmain;
    tmp: Boolean;

implementation
{$R *.dfm}

function   MouseToScreen(mVertical:   Boolean;   mMouse:   Integer):   Integer;
begin
      case   mVertical   of
          False:   Result   :=   Round(mMouse   *   (MAXWORD   /   Screen.Width));
      else
           Result   :=   Round(mMouse   *   (MAXWORD   /   Screen.Height));
      end;
end;


procedure Tfrmxjmain.ApplicationEventsXJActionExecute(Action: TBasicAction;
  var Handled: Boolean);
begin

end;

procedure Tfrmxjmain.ApplicationEventsXJMessage(var Msg: tagMSG; var
    Handled: Boolean);
var
    index: integer;
begin
    if (Msg.message = WM_RBUTTONDOWN) and tmp and (N2.Hint =
        '屏蔽右键关闭功能') then
    begin
        tmp := False;
        index := pgc1.ActivePageIndex;
        frommousemove := Tfrommousemove.Create(self);
        frommousemove.ShowModal;
        tmp := True;
        if rslt then
        begin
            if (index >= 1) and (pgc1.Pages[index].TabVisible) then
            begin
                freepage(index);
            end
            else
            begin
                self.Close;
            end;
            if Assigned(frommousemove) then
            begin
                FreeAndNil(frommousemove);
            end;
        end
        else
        begin
            if Assigned(frommousemove) then
            begin
                FreeAndNil(frommousemove);
            end;
        end;

    end;
end;

procedure Tfrmxjmain.createForm(Formname: string);
var
    TabSheet: TRzTabSheet;
    index, i: Integer;
begin
    index := 0;
    if Formname = 'frmcreatetabletool' then
    begin
        try
            //创建窗口
            if Assigned(frmcreatetabletool) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmcreatetabletool.Caption
                        then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;

                exit;
            end;
            try
             //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmcreatetabletool := Tfrmcreatetabletool.Create(self);
            frmcreatetabletool.Parent := TabSheet;
            frmcreatetabletool.BorderStyle := bsNone;
            frmcreatetabletool.Top := 0;
            frmcreatetabletool.Left := 0;
            frmcreatetabletool.Width := TabSheet.Width;
            frmcreatetabletool.Height := TabSheet.Height;
            frmcreatetabletool.Align := alClient;
            TabSheet.Caption := frmcreatetabletool.Caption;
            frmcreatetabletool.Show;
        except
            FreeAndNil(frmcreatetabletool);
            Abort;
        end;
    end
    else if Formname = 'frmsqlstrtodelphi' then
    begin
        try
            //创建窗口
            if Assigned(frmsqlstrtodelphi) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmsqlstrtodelphi.Caption
                        then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;
                exit;
            end;

            try
                //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmsqlstrtodelphi := Tfrmsqlstrtodelphi.Create(self);
            frmsqlstrtodelphi.Parent := TabSheet;
            frmsqlstrtodelphi.BorderStyle := bsNone;
            frmsqlstrtodelphi.Top := 0;
            frmsqlstrtodelphi.Left := 0;
            frmsqlstrtodelphi.Width := TabSheet.Width;
            frmsqlstrtodelphi.Height := TabSheet.Height;
            frmsqlstrtodelphi.Align := alClient;
            TabSheet.Caption := frmsqlstrtodelphi.Caption;
            frmsqlstrtodelphi.Show;
        except
            FreeAndNil(frmsqlstrtodelphi);
            Abort;
        end;
    end
    else if Formname = 'frmjbzcodetool' then
    begin
        try
            //创建窗口
            if Assigned(frmjbzcodetool) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmjbzcodetool.Caption
                        then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;
                exit;
            end;

            try
                //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmjbzcodetool := Tfrmjbzcodetool.Create(self);
            frmjbzcodetool.Parent := TabSheet;
            frmjbzcodetool.BorderStyle := bsNone;
            frmjbzcodetool.Top := 0;
            frmjbzcodetool.Left := 0;
            frmjbzcodetool.Width := TabSheet.Width;
            frmjbzcodetool.Height := TabSheet.Height;
            frmjbzcodetool.Align := alClient;
            TabSheet.Caption := frmjbzcodetool.Caption;
            //关联窗体关闭时，执行的函数。
            //Form.OnClose := CloseTabSheet;
            frmjbzcodetool.Show;
        except
            FreeAndNil(frmjbzcodetool);
            Abort;
        end;
    end
    else if Formname = 'frmgetzw' then
    begin
        try
            //创建窗口
            if Assigned(frmgetzw) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmgetzw.Caption then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;
                exit;
            end;

            try
                //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmgetzw := Tfrmgetzw.Create(self);
            frmgetzw.Parent := TabSheet;
            frmgetzw.BorderStyle := bsNone;
            frmgetzw.Top := 0;
            frmgetzw.Left := 0;
            frmgetzw.Width := TabSheet.Width;
            frmgetzw.Height := TabSheet.Height;
            frmgetzw.Align := alClient;
            TabSheet.Caption := frmgetzw.Caption;
            //关联窗体关闭时，执行的函数。
            //Form.OnClose := CloseTabSheet;
            frmgetzw.Show;
        except
            FreeAndNil(frmgetzw);
            Abort;
        end;
    end
    else if Formname = 'frmNat' then
    begin
        try
            //创建窗口
            if Assigned(frmNat) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmNat.Caption then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;
                exit;
            end;

            try
                //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmNat := TfrmNat.Create(self);
            frmNat.Parent := TabSheet;
            frmNat.BorderStyle := bsNone;
            frmNat.Top := 0;
            frmNat.Left := 0;
            frmNat.Width := TabSheet.Width;
            frmNat.Height := TabSheet.Height;
            frmNat.Align := alClient;
            TabSheet.Caption := frmNat.Caption;
            //关联窗体关闭时，执行的函数。
            //Form.OnClose := CloseTabSheet;
            frmNat.Show;
        except
            FreeAndNil(frmNat);
            Abort;
        end;
    end
    else if Formname = 'frmbillcode' then
    begin
        try
            //创建窗口
            if Assigned(frmNat) then
            begin
                for i := 0 to pgc1.PageCount - 1 do
                begin
                    if pgc1.Pages[i].Caption = frmbillcode.Caption
                        then
                    begin
                        index := i;
                        Break;
                    end;

                end;

                pgc1.ActivePageIndex := index;
                exit;
            end;

            try
                //创建新标签页
                TabSheet := TRzTabSheet.Create(self);
                TabSheet.PageControl := pgc1;
                TabSheet.Align := alClient;
            except
                FreeAndNil(TabSheet);
                Exit;
            end;
            frmbillcode := Tfrmbillcode.Create(self);
            frmbillcode.Parent := TabSheet;
            frmbillcode.BorderStyle := bsNone;
            frmbillcode.Top := 0;
            frmbillcode.Left := 0;
            frmbillcode.Width := TabSheet.Width;
            frmbillcode.Height := TabSheet.Height;
            frmbillcode.Align := alClient;
            TabSheet.Caption := frmbillcode.Caption;
            //关联窗体关闭时，执行的函数。
            //Form.OnClose := CloseTabSheet;
            frmbillcode.Show;
        except
            FreeAndNil(frmbillcode);
            Abort;
        end;
    end;

  //设置当前的标签页为活动页
    pgc1.ActivePage := TabSheet;
end;

procedure Tfrmxjmain.FormClose(Sender: TObject; var Action:
    TCloseAction);
begin
    if Assigned(frmcreatetabletool) then
    begin
        FreeAndNil(frmcreatetabletool);
    end;

    if Assigned(frmsqlstrtodelphi) then
    begin
        FreeAndNil(frmsqlstrtodelphi);
    end;

    if Assigned(frmNat) then
    begin
        FreeAndNil(frmNat);
    end;

    if Assigned(frmjbzcodetool) then
    begin
        FreeAndNil(frmjbzcodetool);
    end;

    if Assigned(frmgetzw) then
    begin
        FreeAndNil(frmgetzw);
    end;
    if Assigned(frmbillcode) then
    begin
        FreeAndNil(frmbillcode);
    end;

    if Assigned(frommousemove) then
    begin
        FreeAndNil(frommousemove);
    end;
end;

procedure Tfrmxjmain.FormCreate(Sender: TObject);
begin
    tmp := True;
end;

procedure Tfrmxjmain.freepage(index: integer);
begin
    if pgc1.Pages[index].Caption = frmcreatetabletool.Caption then
    begin
        if Assigned(frmcreatetabletool) then
            FreeAndNil(frmcreatetabletool);
    end
    else if pgc1.Pages[index].Caption = frmsqlstrtodelphi.Caption
        then
    begin
        if Assigned(frmsqlstrtodelphi) then
            FreeAndNil(frmsqlstrtodelphi);
    end
    else if pgc1.Pages[index].Caption = frmNat.Caption then
    begin
        if Assigned(frmNat) then
            FreeAndNil(frmNat);
    end
    else if pgc1.Pages[index].Caption = frmjbzcodetool.Caption then
    begin
        if Assigned(frmjbzcodetool) then
            FreeAndNil(frmjbzcodetool);
    end
    else if pgc1.Pages[index].Caption = frmgetzw.Caption then
    begin
        if Assigned(frmgetzw) then
            FreeAndNil(frmgetzw);
    end
    else if pgc1.Pages[index].Caption = frmbillcode.Caption then
    begin
        if Assigned(frmbillcode) then
            FreeAndNil(frmbillcode);
    end;
    pgc1.Pages[index].Free;

    if index - 1 >= 0 then
    begin
        pgc1.ActivePageIndex := index - 1;
    end;
end;

procedure Tfrmxjmain.N2Click(Sender: TObject);
begin
    if N2.Hint = '屏蔽右键关闭功能' then
    begin
        N2.Caption := '开启右键关闭功能';
        N2.Hint := '开启右键关闭功能'
    end
    else
    begin
        N2.Caption := '屏蔽右键关闭功能';
        N2.Hint := '屏蔽右键关闭功能';
    end;
end;

procedure Tfrmxjmain.pgc1Close(Sender: TObject; var AllowClose:
    Boolean);
var
    index: integer;
begin
    AllowClose := True;
    index := pgc1.ActivePageIndex;
    if index >= 0 then
    begin
        freepage(index);
    end;
end;

procedure Tfrmxjmain.pgc1MouseDown(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
var
    index: integer;
begin
    if (Button = mbLeft) and (ssDouble in Shift) then
    begin
        index := pgc1.ActivePageIndex;
        if index >= 0 then
        begin
            Freepage(index);
        end;
    end;
end;

procedure Tfrmxjmain.RzGroup1Items0Click(Sender: TObject);
begin
    RzGroup1.Items[1].Visible := not RzGroup1.Items[1].Visible;
    RzGroup1.Items[2].Visible := not RzGroup1.Items[2].Visible;
end;

procedure Tfrmxjmain.RzGroup1Items1Click(Sender: TObject);
begin
    createForm('frmcreatetabletool');
end;

procedure Tfrmxjmain.RzGroup1Items2Click(Sender: TObject);
begin
    createForm('frmsqlstrtodelphi');
end;

procedure Tfrmxjmain.RzGroup1Items3Click(Sender: TObject);
begin
    createForm('frmjbzcodetool');
end;

procedure Tfrmxjmain.RzGroup1Items4Click(Sender: TObject);
begin
    createForm('frmgetzw');
end;

procedure Tfrmxjmain.RzGroup1Items5Click(Sender: TObject);
begin
    createForm('form6');
end;

procedure Tfrmxjmain.RzGroup1Items6Click(Sender: TObject);
begin
    createForm('frmNat');
end;

procedure Tfrmxjmain.RzGroup2Items0Click(Sender: TObject);
begin
    createForm('frmbillcode');
end;

end.

如图：