给 TStringGrid 添加鼠标拖动功能 回复 "dxx" 的问题

问题来源: http://www.cnblogs.com/del/archive/2008/12/11/1091310.html#1398793

---

本例效果图(这个例子还有问题, 拖动和移动的距离单位不一样):

---

代码文件:

---

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  flag: Boolean;
  x1,y1: Integer;

{初始化测试数据}
procedure TForm1.FormCreate(Sender: TObject);
var
  i,j: Integer;
begin
  StringGrid1.ColCount := 100;
  StringGrid1.RowCount := 100;
  StringGrid1.Align := alClient;
  StringGrid1.Options := StringGrid1.Options - [goRangeSelect];
  for i := 0 to StringGrid1.ColCount - 1 do
    for j := 0 to StringGrid1.RowCount - 1 do
      StringGrid1.Cells[i,j] := IntToStr(i*j);
end;

procedure TForm1.StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if not(ssCtrl in Shift) then Exit; {假如是按住 Ctrl 才能拖动}
  flag := True;
  x1 := X;
  y1 := Y;
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  px,py: Integer;
begin
  if not flag then Exit;
  //if not(ssCtrl in Shift) then Exit;

  px := GetScrollPos(StringGrid1.Handle, SB_HORZ);
  py := GetScrollPos(StringGrid1.Handle, SB_VERT);
  px := px - (X - x1);
  py := py - (Y - y1);

  StringGrid1.Perform(WM_HSCROLL, px shl 16 or SB_THUMBPOSITION, 0);
  StringGrid1.Perform(WM_VSCROLL, py shl 16 or SB_THUMBPOSITION, 0);

  x1 := X;
  y1 := Y;
end;

procedure TForm1.StringGrid1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  flag := False;
end;

end.

窗体文件:

---

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 187
  ClientWidth = 310
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object StringGrid1: TStringGrid
    Left = 8
    Top = 8
    Width = 281
    Height = 153
    TabOrder = 0
    OnMouseDown = StringGrid1MouseDown
    OnMouseMove = StringGrid1MouseMove
    OnMouseUp = StringGrid1MouseUp
  end
end