tvplanit: Mouse wheel support for DayView

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4728 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/tvplanit/source/vpbase.pas

@@ -149,12 +149,8 @@ type
     procedure CMVisibleChanged(var Msg : TMessage); message CM_VISIBLECHANGED;
     {$IFNDEF LCL}
     procedure WMMouseWheel(var Msg : TMessage); message WM_MOUSEWHEEL;
-    {$ELSE}
-    procedure WMMouseWheel(var Msg : TLMessage); message LM_MOUSEWHEEL;
-    {$ENDIF}
-
-  protected
     procedure DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); dynamic;
+    {$ENDIF}
     procedure CreateWnd; override;
     property AfterEnter: TNotifyEvent read FAfterEnter write FAfterEnter;
     property AfterExit: TNotifyEvent read FAfterExit write FAfterExit;
@@ -427,14 +423,6 @@ begin
 end;
 {=====}
 
-procedure TVpCustomControl.DoOnMouseWheel(Shift: TShiftState;
-  Delta, XPos, YPos: SmallInt);
-begin
-  if Assigned(FOnMouseWheel) then
-    FOnMouseWheel(Self, Shift, Delta, XPos, YPos);
-end;
-{=====}
-
 function TVpCustomControl.GetVersion: string;
 begin
   Result := VpVersionStr;
@@ -449,17 +437,24 @@ end;
 
 {$IFNDEF LCL}
 procedure TVpCustomControl.WMMouseWheel(var Msg: TMessage);
-{$ELSE}
-procedure TVpCustomControl.WMMouseWheel(var Msg: TLMessage);
-{$ENDIF}
 begin
   with Msg do
-    DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys},
+    DoOnMouseWheel(
-                   HIWORD(wParam) {zDelta},
+      KeysToShiftState(LOWORD(wParam)) {fwKeys},
-                   LOWORD(lParam) {xPos},
+      HIWORD(wParam) {zDelta},
-                   HIWORD(lParam) {yPos}
+      LOWORD(lParam) {xPos},
+      HIWORD(lParam) {yPos}
     );
 end;
+
+procedure TVpCustomControl.DoOnMouseWheel(Shift: TShiftState;
+  Delta, XPos, YPos: SmallInt);
+begin
+  if Assigned(FOnMouseWheel) then
+    FOnMouseWheel(Self, Shift, Delta, XPos, YPos);
+end;
+
+{$ENDIF}
 {=====}
 
 (*****************************************************************************)

components/tvplanit/source/vpcalendar.pas

@@ -229,8 +229,12 @@ type
     procedure CreateWnd; override;
     procedure DoOnChange(Value : TDateTime); dynamic;
     function DoOnGetDateEnabled(ADate : TDateTime) : Boolean; dynamic;
+   {$IFDEF LCL}
+    // .... to be done in DoMouseWheel
+   {$ELSE}
     procedure DoOnMouseWheel(Shift : TShiftState;
                              Delta, XPos, YPos : SmallInt); override;
+   {$ENDIF}
     function IsReadOnly : Boolean; dynamic;
       {-return true if the calendar is in read-only mode}
     procedure KeyDown(var Key : Word; Shift : TShiftState); override;
@@ -973,12 +977,14 @@ begin
 end;
 {=====}
 
+{$IFDEF LCL}
+  // to be done in DoMouseWheel
+{$ELSE}
 procedure TVpCustomCalendar.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
 var
   Key : Word;
 begin
   inherited DoOnMouseWheel(Shift, Delta, XPos, YPos);
-{$IFNDEF LCL}
   if Abs(Delta) = WHEEL_DELTA then begin
     {inc/dec month}
     if Delta < 0 then
@@ -1001,8 +1007,8 @@ begin
       Key := VK_UP;
     KeyDown(Key, []);
   end;
-{$ENDIF}
 end;
+{$ENDIF}
 {=====}
 
 function TVpCustomCalendar.IsReadOnly : Boolean;

components/tvplanit/source/vpdayview.pas

@@ -332,8 +332,7 @@ type
     procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
       var Accept: Boolean); override;
     { internal methods }
-    function dvCalcRowHeight (Scale   : Extended;
+    function dvCalcRowHeight (Scale: Extended; UseGran: TVpGranularity): Integer;
-                              UseGran : TVpGranularity) : Integer;
     function dvCalcVisibleLines (RenderHeight  : Integer;
                                  ColHeadHeight : Integer;
                                  RowHeight     : Integer;
@@ -361,8 +360,7 @@ type
     procedure Paint; override;
     procedure Loaded; override;
     procedure dvSpawnEventEditDialog(NewEvent: Boolean);
-    procedure dvSetActiveRowByCoord (Pnt    : TPoint;                   
+    procedure dvSetActiveRowByCoord(Pnt: TPoint; Sloppy: Boolean);
-                                     Sloppy : Boolean);                 
     procedure dvSetActiveColByCoord(Pnt: TPoint);
     procedure dvPopulate;
     procedure dvNavButtonsClick(Sender: TObject);
@@ -372,33 +370,31 @@ type
     procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
     procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
     procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
-    {$IFNDEF LCL}
-    procedure WMLButtonDblClk(var Msg : TWMLButtonDblClk);
-      message WM_LBUTTONDBLCLK;
-    {$ELSE}
-    procedure WMLButtonDblClk(var Msg : TLMLButtonDblClk);  message LM_LBUTTONDBLCLK;
-    {$ENDIF}
     procedure SetActiveEventByCoord (APoint : TPoint);                   
     function EditEventAtCoord(Point: TPoint): Boolean;
     function GetEventAtCoord(Point: TPoint): TVpEvent;
     procedure EditEvent;
     procedure EndEdit(Sender: TObject);
     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
-    procedure SetTimeIntervals (UseGran : TVpGranularity);
+    procedure SetTimeIntervals(UseGran: TVpGranularity);
     { message handlers }
-    procedure VpDayViewInit (var Msg : TMessage); Message Vp_DayViewInit;
+    procedure VpDayViewInit(var Msg: TMessage); message Vp_DayViewInit;
     {$IFNDEF LCL}
+    procedure WMLButtonDblClk(var Msg : TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
     procedure WMSize(var Msg: TWMSize); message WM_SIZE;
     procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
     procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS;
-    procedure WMEraseBackground (var Msg : TWMERASEBKGND);
+    procedure WMEraseBackground (var Msg : TWMERASEBKGND);   // ??? wp: missing "message WM_ERASEBKGN"?
-    procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey);
+    procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
-      message CM_WANTSPECIALKEY;
     {$ELSE}
+    function  DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
+    function  DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
+    function  DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
     procedure WMSize(var Msg: TLMSize); message LM_SIZE;
     procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
-    procedure WMSetFocus(var Msg : TLMSetFocus); message LM_SETFOCUS;
+    procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS;
-    procedure WMEraseBackground (var Msg : TLMERASEBKGND);
+    procedure WMEraseBackground(var Msg: TLMERASEBKGND);  // ??? wp: missing "message WM_ERASEBKGN"?
+    procedure WMLButtonDblClk(var Msg: TLMLButtonDblClk); message LM_LBUTTONDBLCLK;
     {$ENDIF}
   public
     constructor Create(AOwner: TComponent); override;
@@ -407,8 +403,7 @@ type
 
     procedure DeleteActiveEvent(Verify: Boolean);
     procedure DragDrop(Source: TObject; X, Y: Integer); override;
-    function HourToLine (const Value   : TVpHours;
+    function HourToLine (const Value: TVpHours; const UseGran: TVpGranularity): Integer;
-                         const UseGran : TVpGranularity) : Integer;
     procedure Invalidate; override;
     procedure LinkHandler(Sender: TComponent;
       NotificationType: TVpNotificationType;
@@ -1447,8 +1442,9 @@ begin
     Result := FNumDays;                                                  
 end;                                                                     
 {=====}
-function TVpDayView.HourToLine (const Value   : TVpHours;
+
-                                 const UseGran : TVpGranularity) : Integer;
+function TVpDayView.HourToLine (const Value: TVpHours;
+  const UseGran: TVpGranularity): Integer;
 begin
   case UseGran of
     gr60Min : Result := Ord (Value);
@@ -1458,8 +1454,7 @@ begin
     gr10Min : Result := Ord (Value) * 6;
     gr06Min : Result := Ord (Value) * 10;
     gr05Min : Result := Ord (Value) * 12;
-    else
+    else      Result := Ord (Value) * 2; { Default to 30 minutes }
-      Result := Ord (Value) * 2; { Default to 30 minutes }
   end;
 end;
 
@@ -2029,6 +2024,54 @@ begin
 end;
 {=====}
 
+{$IFDEF LCL}
+{
+procedure TVpDayView.WMMouseWheel(var Message: TLMMouseEvent);
+begin
+  inherited;
+end;
+ }
+function TVpDayView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
+  MousePos: TPoint): Boolean;
+begin
+  Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
+end;
+
+function TVpDayView.DoMouseWheelDown(Shift: TShiftState;
+  MousePos: TPoint): Boolean;
+var
+  delta: Integer;
+begin
+  Result := inherited DoMouseWheelDown(Shift, MousePos);
+  if not Result then begin
+    if [ssCtrl, ssShift] * Shift <> [] then begin
+      delta := HourToLine(h_01, FGranularity);
+      if delta = 1 then delta := 3;
+    end else
+      delta := 1;
+    dvScrollVertical(delta);
+    Result := True;
+  end;
+end;
+
+function TVpDayView.DoMouseWheelUp(Shift: TShiftState;
+  MousePos: TPoint): Boolean;
+var
+  delta: Integer;
+begin
+  Result := inherited DoMouseWheelUp(Shift, MousePos);
+  if not Result then begin
+    if [ssCtrl, ssShift] * Shift <> [] then begin
+      delta := HourToLine(h_01, FGranularity);
+      if delta = 1 then delta := 3;
+    end else
+      delta := 1;
+    dvScrollVertical(-delta);
+    Result := True;
+  end;
+end;
+{$ENDIF}
+
 procedure TVpDayView.EditSelectedEvent;
 begin
   if ReadOnly then