cxcontrols.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,976 行 · 第 1/5 页

  protected
    function GetImageBackColor: TColor; virtual;
    property ImageBackColor: TColor read GetImageBackColor;
  public
    constructor Create(ATransparent: Boolean); reintroduce; virtual;
    procedure Init(AOwner: TControl; const AAreaBounds, AClientRect: TRect;
      APlace: TcxArrowPlace);
    property Transparent: Boolean read GetTransparent;
  end;

  { TcxTimer }

  TcxTimer = class (TComponent)
  private
    FEnabled: Boolean;
    FEventID: Cardinal;
    FInterval: Cardinal;
    FTimerOn: Boolean;
    FOnTimer: TNotifyEvent;
    function CanSetTimer: Boolean;
    procedure KillTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
    procedure SetTimer;
    procedure SetTimerOn(Value: Boolean);
    procedure UpdateTimer;
    property TimerOn: Boolean read FTimerOn write SetTimerOn;
  protected
    procedure TimeOut; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;

  { TcxDesignController }

  TcxDesignState = (dsDesignerModifying);
  TcxDesignStates = set of TcxDesignState;

  TcxDesignController = class
  private
    FLockDesignerModifiedCount: Integer;
  protected
    FState: TcxDesignStates;
  public
    procedure DesignerModified(AForm: TCustomForm); overload;
    function IsDesignerModifiedLocked: Boolean;
    procedure LockDesignerModified;
    procedure UnLockDesignerModified;
  end;

function CanAllocateHandle(AControl: TWinControl): Boolean;
function cxMessageWindow: TcxMessageWindow;
function cxMessageDlg(const AMessage, ACaption: string; ADlgType: TMsgDlgType;
  AButtons: TMsgDlgButtons; AHelpCtx: Longint): Integer;
function DragDetect(Wnd: HWND): TcxDragDetect;
function GetMouseKeys: WPARAM;
function GetDblClickInterval: Integer;
function GetDesktopWorkArea(const P: TPoint): TRect;
function GetMonitorWorkArea(const AMonitor: Integer): TRect;
function GetMouseCursorPos: TPoint;
function GetPointPosition(const ARect: TRect; const P: TPoint;
  AHorzSeparation, AVertSeparation: Boolean): TcxPosition;
function IsChildClassWindow(AWnd: HWND): Boolean;
function IsChildEx(AParentWnd, AWnd: HWND): Boolean;
function IsCtrlPressed: Boolean;
function IsOwner(AOwnerWnd, AWnd: HWND): Boolean;
function IsOwnerEx(AOwnerWnd, AWnd: HWND): Boolean;
function IsPointInDragDetectArea(const AMouseDownPos: TPoint; X, Y: Integer): Boolean;
function IsNumericChar(C: Char; AType: TcxNumberType): Boolean;
function IsTextChar(C: Char): Boolean;
procedure MakeVisibleOnDesktop(var ABounds: TRect; const ADesktopPoint: TPoint); overload;
procedure MakeVisibleOnDesktop(AControl: TControl); overload;
procedure MapWindowPoint(AHandleFrom, AHandleTo: TcxHandle; var P: TPoint);
procedure MapWindowRect(AHandleFrom, AHandleTo: TcxHandle; var R: TRect);
procedure RecreateControlWnd(AControl: TWinControl);
function RemoveAccelChars(const S: string; AAppendTerminatingUnderscore: Boolean = True): string;
procedure SetDesignerModified(AComponent: TComponent);
function ShiftStateToKeys(AShift: TShiftState): WORD;
function TranslateKey(Key: Word): Word;

// mouse tracking
procedure BeginMouseTracking(AControl: TWinControl; const ABounds: TRect;
  ACaller: IcxMouseTrackingCaller);
procedure EndMouseTracking(ACaller: IcxMouseTrackingCaller);
function IsMouseTracking(ACaller: IcxMouseTrackingCaller): Boolean;

// hourglass cursor showing
procedure HideHourglassCursor;
procedure ShowHourglassCursor;

// popup menu routines
function GetPopupMenuHeight(APopupMenu: TPopupMenu): Integer;
function IsPopupMenuShortCut(APopupMenu: TComponent;
  var Message: TWMKey): Boolean;
function ShowPopupMenu(ACaller, AComponent: TComponent; X, Y: Integer): Boolean;
function ShowPopupMenuFromCursorPos(ACaller, AComponent: TComponent): Boolean;

// delphi drag and drop
function GetDragObject: TDragObject;

// drag and drop arrow
function GetDragAndDropArrowBounds(const AAreaBounds, AClientRect: TRect; APlace: TcxArrowPlace): TRect;
procedure GetDragAndDropArrowPoints(const ABounds: TRect; APlace: TcxArrowPlace;
  out P: TPointArray; AForRegion: Boolean);
procedure DrawDragAndDropArrow(ACanvas: TcxCanvas; const ABounds: TRect; APlace: TcxArrowPlace);

procedure DialogApplyFont(ADialog: TCustomForm; AFont: TFont);

function DesignController: TcxDesignController;

function GET_APPCOMMAND_LPARAM(lParam: LPARAM): Integer;
{$EXTERNALSYM GET_APPCOMMAND_LPARAM}

{$IFNDEF DELPHI6}
function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
{$ENDIF}

type
  TcxGetParentFormForDockingFunc = function (AControl: TControl): TCustomForm;
  TcxGetParentWndForDockingFunc = function (AWnd: HWND): HWND;

var
  cxDragAndDropWindowTransparency: Byte = 180;
  cxGetParentFormForDocking: TcxGetParentFormForDockingFunc = nil;
  cxGetParentWndForDocking: TcxGetParentWndForDockingFunc = nil;
  dxSpellCheckerEditHelper: IdxSpellCheckerEditHelper;
  dxWMGetSkinnedMessage: WORD;
  dxWMSetSkinnedMessage: WORD;
  // platform info
  IsWin95X: Boolean;
  IsWin2K: Boolean;
  IsWin2KOrXP: Boolean;
  IsWinNT: Boolean;
  IsWinVista: Boolean;
  IsWinXP: Boolean;

implementation

{$R cxControls.res}

uses
  dxUxTheme,
  dxThemeConsts,
  SysUtils, Math, cxGeometry, cxLibraryConsts;

const
  crFullScroll = crBase + 1;
  crHorScroll = crBase + 2;
  crVerScroll = crBase + 3;
  crUpScroll = crBase + 4;
  crRightScroll = crBase + 5;
  crDownScroll = crBase + 6;
  crLeftScroll = crBase + 7;

  ScreenHandle = 0;
  dxWMGetSkinnedMessageID = '{B2CE3777-44D8-4998-9701-47BBBC10B656}';
  dxWMSetSkinnedMessageID = '{B2CE3777-44D8-1321-4656-12C54AA613BB}';

type
  TControlAccess = class(TControl);
  TCustomFormAccess = class(TCustomForm);
  TMenuItemAccess = class(TMenuItem);

  TcxTimerWindow = class(TcxMessageWindow)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

var
  FUnitIsFinalized: Boolean;
  FDragObject: TDragObject;
  FUser32DLL: HMODULE;
  FcxMessageWindow: TcxMessageWindow;
  FcxTimerWindow: TcxTimerWindow;
  FActiveTimerList: TList;
  FDesignController: TcxDesignController;
  FSystemController: TcxSystemController;

{$IFNDEF DELPHI7}

type
  TSetLayeredWindowAttributes = function(Hwnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;

var
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes = nil;

procedure InitSetLayeredWindowAttributes;
var
  AModule: HMODULE;
begin
  AModule := GetModuleHandle('User32.dll');
  if AModule <> 0 then
    @SetLayeredWindowAttributes := GetProcAddress(AModule, 'SetLayeredWindowAttributes');
end;

{$ENDIF}

function CanAllocateHandle(AControl: TWinControl): Boolean;
begin
  Result := AControl.HandleAllocated or
    not (csDestroying in AControl.ComponentState) and
    ((AControl.ParentWindow <> 0) or
    (AControl.Parent <> nil) and CanAllocateHandle(AControl.Parent) or
    ((AControl is TCustomForm) or (AControl is TCustomFrame)) and (Application <> nil) and (Application.Handle <> 0));
end;

function cxMessageWindow: TcxMessageWindow;
begin
  if (FcxMessageWindow = nil) and not FUnitIsFinalized then
    FcxMessageWindow := TcxMessageWindow.Create;
  Result := FcxMessageWindow;
end;

function cxMessageDlg(const AMessage, ACaption: string; ADlgType: TMsgDlgType;
  AButtons: TMsgDlgButtons; AHelpCtx: Longint): Integer;
begin
  with CreateMessageDialog(AMessage, ADlgType, AButtons) do
  try
    if ACaption <> '' then
      Caption := ACaption;
    HelpContext := AHelpCtx;
    Position := poScreenCenter;
    Result := ShowModal;
  finally
    Free;
  end;
end;

function DragDetect(Wnd: HWND): TcxDragDetect;
var
  NoDragZone: TRect;
  P: TPoint;
  Msg: TMsg;
begin
  Result := ddCancel;

  P := GetMouseCursorPos;
  NoDragZone.Right := 2 * Mouse.DragThreshold;//GetSystemMetrics(SM_CXDRAG);
  NoDragZone.Bottom := 2 * Mouse.DragThreshold;//GetSystemMetrics(SM_CYDRAG);
  NoDragZone.Left := P.X - NoDragZone.Right div 2;
  NoDragZone.Top := P.Y - NoDragZone.Bottom div 2;
  Inc(NoDragZone.Right, NoDragZone.Left);
  Inc(NoDragZone.Bottom, NoDragZone.Top);

  SetCapture(Wnd);
  try
    while GetCapture = Wnd do
    begin
      case Integer(GetMessage(Msg, 0, 0, 0)) of
        -1: Break;
        0: begin
            PostQuitMessage(Msg.wParam);
            Break;
          end;
      end;
      try
        case Msg.message of
          WM_KEYDOWN, WM_KEYUP:
            if Msg.wParam = VK_ESCAPE then Break;
          WM_MOUSEMOVE:
            if Msg.hwnd = Wnd then
            begin
              P := Point(LoWord(Msg.lParam), HiWord(Msg.lParam));
              ClientToScreen(Msg.hwnd, P);
              if not PtInRect(NoDragZone, P) then
              begin
                Result := ddDrag;
                Break;
              end;
            end;
          WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP:
            begin
              Result := ddNone;
              Break;
            end;
        end;
      finally
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
    end;
  finally
    if GetCapture = Wnd then ReleaseCapture;
  end;
end;

function GetMouseKeys: WPARAM;
begin
  Result := 0;
  if GetAsyncKeyState(VK_LBUTTON) < 0 then Inc(Result, MK_LBUTTON);
  if GetAsyncKeyState(VK_MBUTTON) < 0 then Inc(Result, MK_MBUTTON);
  if GetAsyncKeyState(VK_RBUTTON) < 0 then Inc(Result, MK_RBUTTON);
  if GetAsyncKeyState(VK_CONTROL) < 0 then Inc(Result, MK_CONTROL);
  if GetAsyncKeyState(VK_SHIFT) < 0 then Inc(Result, MK_SHIFT);
end;

function GetDblClickInterval: Integer;
begin
  Result := GetDoubleClickTime;
end;

type
  HMONITOR = type Integer;
  PMonitorInfo = ^TMonitorInfo;
  TMonitorInfo = packed record
    cbSize: DWORD;
    rcMonitor: TRect;
    rcWork: TRect;
    dwFalgs: DWORD;
  end;

function GetDesktopWorkArea(const P: TPoint): TRect;
const
  MONITOR_DEFAULTTONEAREST = $2;
var
  AMonitor: Integer;
  MonitorFromPoint: function(ptScreenCoords: TPoint; dwFlags: DWORD): HMONITOR; stdcall;
begin
  AMonitor := 0;
  if FUser32DLL > 32 then
  begin
    MonitorFromPoint := GetProcAddress(FUser32DLL, 'MonitorFromPoint');
    if Assigned(MonitorFromPoint) then
    begin
      AMonitor := MonitorFromPoint(P, MONITOR_DEFAULTTONEAREST);
    end;
  end;
  Result := GetMonitorWorkArea(AMonitor);
end;

function GetMonitorWorkArea(const AMonitor: Integer): TRect;
var
  Info: TMonitorInfo;
  GetMonitorInfo: function(hMonitor: HMONITOR;
    lpMonitorInfo: PMonitorInfo): Boolean; stdcall;
begin
  if FUser32DLL > 32 then
    GetMonitorInfo := GetProcAddress(FUser32DLL, 'GetMonitorInfoA')
  else
    GetMonitorInfo := nil;
  if (AMonitor = 0) or not Assigned(GetMonitorInfo) then
    SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0)
  else
  begin
    Info.cbSize := SizeOf(Info);
    GetMonitorInfo(AMonitor, @Info);
    Result := Info.rcWork;
  end;
end;

function GetMouseCursorPos: TPoint;
begin
  if not Windows.GetCursorPos(Result) then
    Result := cxInvalidPoint;
end;

function GetPointPosition(const ARect: TRect; const P: TPoint;
  AHorzSeparation, AVertSeparation: Boolean): TcxPosition;
const
  Positions: array[Boolean, Boolean] of TcxPosition =
    ((posBottom, posRight), (posLeft, posTop));
type
  TCorner = (BottomLeft, TopLeft, TopRight, BottomRight);

  function GetCornerCoords(ACorner: TCorner): TPoint;
  begin
    case ACorner of
      BottomLeft:
        Result := Point(ARect.Left, ARect.Bottom);
      TopLeft:
        Result := ARect.TopLeft;
      TopRight:
        Result := Point(ARect.Right, ARect.Top);
      BottomRight:
        Result := ARect.BottomRight;
    end;
  end;

  function GetSign(const P1, P2, P: TPoint): Integer;
  begin
    Result := (P.X - P1.X) * (P2.Y - P1.Y) - (P.Y - P1.Y) * (P2.X - P1.X);
  end;

var
  ASign1, ASign2: Integer;
begin
  if AHorzSeparation and AVertSeparation then
  begin
    ASign1 := GetSign(GetCornerCoords(BottomLeft), GetCornerCoords(TopRight), P);
    ASign2 := GetSign(GetCornerCoords(TopLeft), GetCornerCoords(BottomRight), P);