{%MainUnit CustomDrawnInt.pas} { ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } type TWinControlAccess = class(TWinControl); {*************************************************************} { callback routines } {*************************************************************} function WndClassName(Wnd: HWND): WideString; inline; var winClassName: array[0..19] of WideChar; begin GetClassName(Wnd, @winClassName, 20); Result := winClassName; end; {------------------------------------------------------------------------------ Function: CallDefaultWindowProc Params: Window - The window that receives a message Msg - The message received WParam - Word parameter LParam - Long-integer parameter Returns: 0 if Msg is handled; non-zero long-integer result otherwise Passes message on to 'default' handler. This can be a control specific window procedure or the default window procedure. ------------------------------------------------------------------------------} function CallDefaultWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; var PrevWndProc: Windows.WNDPROC; setComboWindow: boolean; WindowInfo: TWindowInfo; begin {$ifdef MSG_DEBUG} DebugLn('Trace:CallDefaultWindowProc - Start'); {$endif} WindowInfo := GetWindowInfo(Window); PrevWndProc := WindowInfo.DefWndProc; if (PrevWndProc = nil) or (PrevWndProc = @WindowProc) // <- prevent recursion then begin {$ifdef MSG_DEBUG} DebugLn('Trace:CallDefaultWindowProc - A'); {$endif} Result := Windows.DefWindowProcW(Window, Msg, WParam, LParam) end else begin {$ifdef MSG_DEBUG} DebugLn('Trace:CallDefaultWindowProc - B ' + IntToHex(PtrInt(PrevWndProc), 8)); {$endif} Result := Windows.CallWindowProc(PrevWndProc, Window, Msg, WParam, LParam); end; end; var DisabledForms: TList = nil; function CheckMouseMovement: boolean; // returns true if mouse did not move between lmousebutton down var lCursorPos: TPoint; moveX, moveY: integer; begin Result := true; { GetCursorPos(lCursorPos); moveX := lCursorPos.X - MouseDownPos.X; moveY := lCursorPos.Y - MouseDownPos.Y; Result := (-3 <= moveX) and (moveX <= 3) and (-3 <= moveY) and (moveY <= 3);} end; {------------------------------------------------------------------------------ Function: WindowProc Params: Window - The window that receives a message Msg - The message received WParam - Word parameter LParam - Long-integer parameter Returns: 0 if Msg is handled; non-zero long-integer result otherwise Handles the messages sent to the specified window, in parameter Window, by Windows or other applications ------------------------------------------------------------------------------} function WindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam): LResult; {$if defined(win32) or defined(win64)}stdcall{$else}cdecl{$endif}; Var LMessage: TLMessage; PLMsg: PLMessage; R: TRect; P: TPoint; NewLeft, NewTop, NewWidth, NewHeight: integer; lWinControl, ChildWinControl: TWinControl; TargetObject: TObject; WinProcess: Boolean; NotifyUserInput: Boolean; WindowPlacement: TWINDOWPLACEMENT; OverlayWindow: HWND; TargetWindow: HWND; WindowInfo: TWindowInfo; Flags: dword; WindowColor: Integer; LMScroll: TLMScroll; // used by WM_HSCROLL LMKey: TLMKey; // used by WM_KEYDOWN WM_KEYUP LMChar: TLMChar; // used by WM_CHAR LMMouse: TLMMouse; // used by WM_LBUTTONDBLCLK LMContextMenu: TLMContextMenu; LMMouseMove: TLMMouseMove; // used by WM_MOUSEMOVE LMMouseEvent: TLMMouseEvent; // used by WM_MOUSEWHEEL LMMove: TLMMove; // used by WM_MOVE LMNotify: TLMNotify; // used by WM_NOTIFY DrawListItemStruct: TDrawListItemStruct; //used by WM_DRAWITEM CancelEndSession : Boolean;//use by WM_QUERYENDSESSION OrgCharCode: word; // used in WM_CHAR handling // Message information XPos, YPos: Integer; WParamShiftState: TShiftState; MouseButton: TMouseButton; UTF8Char: TUTF8Char; NMHdr: PNMHdr absolute LParam; // used by WM_NOTIFY TmpSize: TSize; // used by WM_MEASUREITEM {$ifdef wince} Info: SHRGINFO; // used by SHRecognizeGesture in WM_LBUTTONDOWN {$endif} // CustomDrawn specific lEventReceiver: TWinControl; lEventX: Integer = -1; lEventY: Integer = -1; function GetIsNativeControl(AWindow: HWND): Boolean; begin Result := False;//WndClassName(AWindow) <> ClsName; end; { Differences with LCL-Win32: * Here there are zero native controls * Here nothing needs parent paint * The double buffering from LCL-Win32 is not used, instead we have a different architecture where double buffering is always on, it is impossible to turn it off because all drawings are done to the temporary image first } procedure SendPaintMessage(ControlDC: HDC); var DC: HDC; lBitmap, lMask: HBITMAP; PaintRegion: HRGN; PS : TPaintStruct; PaintMsg: TLMPaint; WindowOrg: Windows.POINT; WindowWidth, WindowHeight: Integer; DCIndex: integer; parLeft, parTop: integer; needParentPaint: boolean; BufferWasSaved: Boolean; lRawImage: TRawImage; begin if lWinControl = nil then exit; {$IFDEF VerboseCDMessages} DebugLn(Format('[SendPaintMessage]: Control:%s:%s', [lWinControl.Name, lWinControl.ClassName])); {$ENDIF} // create a paint message needParentPaint := False; LCLIntf.GetWindowSize(HWND(WindowInfo), WindowWidth, WindowHeight); // Start the double buffering by checking if we need to increase the buffer if (WindowInfo.BitmapWidth < WindowWidth) or (WindowInfo.BitmapHeight < WindowHeight) then begin // first release old objects if WindowInfo.BitmapDC <> 0 then begin Windows.SelectObject(WindowInfo.BitmapDC, WindowInfo.DCBitmapOld); Windows.DeleteObject(WindowInfo.BitmapDC); end; if WindowInfo.Bitmap <> 0 then Windows.DeleteObject(WindowInfo.Bitmap); // And now create the new ones DC := Windows.GetDC(0); WindowInfo.BitmapDC := Windows.CreateCompatibleDC(0); WindowInfo.BitmapWidth := WindowWidth; WindowInfo.BitmapHeight := WindowHeight; WindowInfo.Bitmap := Windows.CreateCompatibleBitmap(DC, WindowWidth, WindowHeight); WindowInfo.DCBitmapOld := Windows.SelectObject(WindowInfo.BitmapDC, WindowInfo.Bitmap); Windows.ReleaseDC(0, DC); // Reset the image and canvas WindowInfo.Canvas.Free; WindowInfo.Canvas := nil; WindowInfo.Image.Free; WindowInfo.Image := nil; end; // Prepare the non-native Canvas if necessary if (WindowInfo.Image = nil) then begin WinProc_RawImage_FromBitmap(lRawImage, WindowInfo.Bitmap, 0); WindowInfo.Image := TLazIntfImage.Create(WindowWidth, WindowHeight); WindowInfo.Image.SetRawImage(lRawImage); end; if (WindowInfo.Canvas = nil) then WindowInfo.Canvas := TLazCanvas.Create(WindowInfo.Image); {$ifdef VerboseCDMessages} DebugLn(Format('[SendPaintMessage] WindowInfo^.Canvas=%s', [dbghex(PtrInt(WindowInfo.Canvas))])); {$endif} // main processing WinProcess := false; try if ControlDC = 0 then begin // ignore first erase background on themed control, paint will do everything DC := Windows.BeginPaint(Window, @PS); end else begin DC := ControlDC; PaintRegion := 0; end; // Draw the form RenderForm(WindowInfo.Image, WindowInfo.Canvas, TCustomForm(lWinControl)); // Now convert the rawimage to a HBITMAP and draw it to the screen WindowInfo.Image.GetRawImage(lRawImage); WinProc_RawImage_CreateBitmaps(lRawImage, lBitmap, lMask, True); Windows.SelectObject(WindowInfo.BitmapDC, lBitmap); Windows.BitBlt(DC, 0, 0, WindowWidth, WindowHeight, WindowInfo.BitmapDC, 0, 0, SRCCOPY); Windows.SelectObject(WindowInfo.BitmapDC, WindowInfo.Bitmap); Windows.DeleteObject(lBitmap); if ControlDC = 0 then Windows.EndPaint(Window, @PS); finally end; {$ifdef VerboseCDMessages} DebugLn(':< [SendPaintMessage] Finish'); {$endif} end; procedure HandleSetCursor; var lControl: TControl; BoundsOffset: TRect; ACursor: TCursor; begin if (lWinControl <> nil) and not (csDesigning in lWinControl.ComponentState) and (Lo(LParam) = HTCLIENT) then begin Windows.GetCursorPos(@(Windows.POINT(P))); Windows.ScreenToClient(Window, @(Windows.POINT(P))); if GetLCLClientBoundsOffset(lWinControl, BoundsOffset) then begin Dec(P.X, BoundsOffset.Left); Dec(P.Y, BoundsOffset.Top); end; ACursor := Screen.RealCursor; if ACursor = crDefault then begin // statictext controls do not get WM_SETCURSOR messages... lControl := lWinControl.ControlAtPos(P, [capfOnlyClientAreas, capfAllowWinControls, capfHasScrollOffset, capfRecursive]); if lControl = nil then lControl := lWinControl; ACursor := lControl.Cursor; end; if ACursor <> crDefault then begin Windows.SetCursor(Screen.Cursors[ACursor]); LMessage.Result := 1; end; end; if LMessage.Result = 0 then begin LMessage.Msg := LM_SETCURSOR; LMessage.WParam := WParam; LMessage.LParam := LParam; end; WinProcess := false; end; procedure HandleSysCommand; var ParentForm: TCustomForm; prevFocus: HWND; begin // forward keystroke to show window menu, if parent form has no menu // if wparam contains SC_KEYMENU, lparam contains key pressed // keymenu+space should always bring up system menu case (WParam and $FFF0) of SC_KEYMENU: if (lWinControl <> nil) and (lParam <> VK_SPACE) then begin ParentForm := GetParentForm(lWinControl); if (ParentForm <> nil) and (ParentForm.Menu = nil) and (Application <> nil) and (Application.MainForm <> nil) and (Application.MainForm <> ParentForm) and Application.MainForm.HandleAllocated then begin targetWindow := Application.MainForm.Handle; if IsWindowEnabled(targetWindow) and IsWindowVisible(targetWindow) then begin prevFocus := Windows.GetFocus; Windows.SetFocus(targetWindow); PLMsg^.Result := Windows.SendMessageW(targetWindow, WM_SYSCOMMAND, WParam, LParam); Windows.SetFocus(prevFocus); WinProcess := false; end; end; end; //roozbeh : we do not have these in wince! { SC_MINIMIZE: begin if (Application <> nil) and (lWinControl <> nil) and (Application.MainForm <> nil) and (Application.MainForm = lWinControl) then Window := TWinCEWidgetSet(WidgetSet).AppHandle;//redirection if (Window = TWinCEWidgetSet(WidgetSet).AppHandle) and (Application <> nil) and (Application.MainForm<>nil) then begin Windows.SetWindowPos(Window, HWND_TOP, Application.MainForm.Left, Application.MainForm.Top, Application.MainForm.Width, 0, SWP_NOACTIVATE); if Application.MainForm.HandleAllocated then Windows.ShowWindow(Application.MainForm.Handle,SW_HIDE); Application.IntfAppMinimize; end; end;} {SC_RESTORE: begin if (Window = TWinCEWidgetSet(WidgetSet).AppHandle) and (Application <> nil) and (Application.MainForm<>nil) and Application.MainForm.HandleAllocated then begin PLMsg^.Result := Windows.DefWindowProc(Window, WM_SYSCOMMAND, WParam, LParam); Windows.ShowWindow(Application.MainForm.Handle,SW_SHOW); if Windows.IsWindowEnabled(Application.MainForm.Handle) then Windows.SetActiveWindow(Application.MainForm.Handle); WinProcess := false; Application.IntfAppRestore; end; end;} end; end; begin //DebugLn('Trace:WindowProc - Start'); LMessage.Result := 0; LMessage.Msg := LM_NULL; PLMsg := @LMessage; WinProcess := True; NotifyUserInput := False; {$ifdef VerboseCDMessages} DebugLn(Format('WindowProc Window= %x FAppHandle=%x MSG=%s', [Window, CDWidgetset.FAppHandle, WM_To_String(Msg)])); {$endif} //DebugLn('Trace:WindowProc - Getting Object with Callback Procedure'); WindowInfo := GetWindowInfo(Window); lWinControl := WindowInfo.LCLForm; {$ifdef VerboseCDMessages} DebugLn('WindowProc lWinControl: ',DbgSName(lWinControl)); {$endif} if (IgnoreNextCharWindow <> 0) and ((Msg = WM_CHAR) or (Msg = WM_SYSCHAR)) then begin if IgnoreNextCharWindow = Window then begin IgnoreNextCharWindow := 0; Result := 1; exit; end; IgnoreNextCharWindow := 0; end; {$ifdef MSG_DEBUG} DebugLn('Trace:WindowProc - Case Msg of'); {$endif} case Msg Of WM_NULL: begin CheckSynchronize; {TCDWidgetset(Widgetset).CheckPipeEvents;} end; WM_ACTIVATE: begin LMessage.Msg := LM_ACTIVATE; end; WM_CAPTURECHANGED: begin LMessage.Msg := LM_CAPTURECHANGED; end; WM_CHAR: begin UTF8Char := UTF8Encode(widestring(WideChar(WParam))); CallbackKeyChar(WindowInfo, Word(Char(WideChar(WParam))), UTF8Char); Result := 1; Exit; end; WM_CLOSE: begin if (Window = TCDWidgetSet(WidgetSet).AppHandle) and (Application.MainForm <> nil) then begin Windows.SendMessage(Application.MainForm.Handle, WM_CLOSE, 0, 0); end else begin LMessage.Msg := LM_CLOSEQUERY; end; // default is to destroy window, inhibit WinProcess := false; end; { WM_COMMAND Parameters: wNotifyCode = HIWORD(wParam); wID = LOWORD(wParam); hwndCtl = (HWND) lParam; If wID is IDOK, then we have received a close message from the "OK" button in the title of dialog windows. } WM_COMMAND: begin { Handles the "OK" button in the title bar of dialogs } if Lo(wParam) = IDOK then begin if (lWinControl is TCustomForm) and (fsModal in TCustomForm(lWinControl).FormState) then TCustomForm(lWinControl).ModalResult := mrOK else SendMessage(Window, WM_CLOSE, 0, 0); end; (* else begin { Handles other reasons for WM_COMMAND } if Hi(WParam) < 2 then //1 for accelerator 0 for menu begin {$ifdef VerboseWinCEMenu} DebugLn('[wincecallback] Hi(WParam) < 2'); {$endif} TargetObject := GetMenuItemObject(); end else // menuitem or shortcut begin TargetObject := nil; end; if TargetObject is TMenuItem then begin {$ifdef VerboseWinCEMenu} DebugLn('[wincecallback] Sending menuitem Click'); {$endif} LMessage.Msg := LM_ACTIVATE; TargetObject.Dispatch(LMessage); lWinControl := nil; end else begin lWinControl := GetWindowInfo(LParam)^.WinControl; // buddy controls use 'awincontrol' to designate associated wincontrol if lWinControl = nil then lWinControl := GetWindowInfo(LParam)^.AWinControl; end; // no specific message found? try send a general msg if (LMessage.Msg = LM_NULL) and (lWinControl <> nil) then lWinControl.Perform(CN_COMMAND, WParam, LParam); end;*) end; { * Besides the fact that LCL does not respond to LM_CREATE, this code is probably never reached anyway, as the callback is not set until after window creation WM_CREATE: begin //DebugLn('Trace:WindowProc - Got WM_CREATE'); LMessage.Msg := LM_CREATE; end; } WM_CLEAR: begin LMessage.Msg := LM_CLEAR; end; WM_COPY: begin LMessage.Msg := LM_COPY; end; WM_CUT: begin LMessage.Msg := LM_CUT; end; WM_DESTROY: begin LMessage.Msg := LM_DESTROY; end; WM_DESTROYCLIPBOARD: begin if assigned(OnClipBoardRequest) then begin // {$IFDEF VerboseWin32Clipbrd} // debugln('WM_DESTROYCLIPBOARD'); // {$ENDIF} OnClipBoardRequest(0, nil); OnClipBoardRequest := nil; LMessage.Result := 0; end; end; WM_ENABLE: begin if WParam <> 0 then LMessage.Msg := LM_SETEDITABLE; if Window = TCDWidgetSet(WidgetSet).FAppHandle then if WParam = 0 then DisabledForms := Screen.DisableForms(nil, DisabledForms) else Screen.EnableForms(DisabledForms); end; WM_ENTERIDLE: Application.Idle(False); WM_ERASEBKGND: begin {eraseBkgndCommand := TEraseBkgndCommand(EraseBkgndStack and EraseBkgndStackMask); if eraseBkgndCommand = ecDoubleBufferNoRemove then begin end else if eraseBkgndCommand <> ecDiscardNoRemove then EraseBkgndStack := EraseBkgndStack shr EraseBkgndStackShift; if eraseBkgndCommand in [ecDiscard, ecDiscardNoRemove] then begin Result := 0; exit; end; if not False or (eraseBkgndCommand = ecDoubleBufferNoRemove) then begin LMessage.Msg := LM_ERASEBKGND; LMessage.WParam := WParam; LMessage.LParam := LParam; end else begin SendPaintMessage(HDC(WParam)); LMessage.Result := 1; end;} WinProcess := False; end; { WM_EXITMENULOOP: // is it a popup menu if longbool(WPARAM) and assigned(WindowInfo^.PopupMenu) then WindowInfo^.PopupMenu.Close; WM_GETDLGCODE: begin LMessage.Result := DLGC_WANTALLKEYS; WinProcess := false; end;} { * TODO: make it work... icon does not show up yet, so better disable it WM_GETICON: begin if WindowInfo^.WinControl is TCustomForm then begin LMessage.Result := TCustomForm(WindowInfo^.WinControl).GetIconHandle; WinProcess := false; end; end; } WM_KEYDOWN: begin CallbackKeyDown(WindowInfo, Word(WParam)); Result := 1; Exit; end; WM_KEYUP: begin CallbackKeyUp(WindowInfo, Word(WParam)); Result := 1; Exit; end; WM_KILLFOCUS: begin {$ifdef DEBUG_CARET} DebugLn('WM_KILLFOCUS received for window ', IntToHex(Window, 8)); {$endif} LMessage.Msg := LM_KILLFOCUS; LMessage.WParam := WParam; end; //TODO:LM_KILLCHAR,LM_KILLWORD,LM_KILLLINE WM_LBUTTONDBLCLK: begin NotifyUserInput := True; PLMsg:=@LMMouse; with LMMouse Do begin Msg := LM_LBUTTONDBLCLK; XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); Keys := WParam; lEventX := XPos; lEventY := YPos; end; end; WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN: begin {$ifdef wince} // Gesture recognition process to enable popup menus. if (lWinControl.PopupMenu <> nil) and (Msg = WM_LBUTTONDOWN) then begin Info.cbSize := SizeOf(SHRGINFO); Info.dwFlags := SHRG_RETURNCMD; Info.hwndClient := Window; Info.ptDown.x := Lo(LParam); Info.ptDown.y := Hi(LParam); SHRecognizeGesture(Info); end; {$endif} XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); if GetLCLClientBoundsOffset(WindowInfo, R) then begin Dec(XPos, R.Left); Dec(YPos, R.Top); end; WParamShiftState := KeysToShiftState(WParam); //MsgKeyDataToShiftState case Msg of WM_LBUTTONDOWN: MouseButton := mbLeft; WM_MBUTTONDOWN: MouseButton := mbMiddle; WM_RBUTTONDOWN: MouseButton := mbRight; end; CallbackMouseDown(WindowInfo, XPos, YPos, MouseButton, WParamShiftState); Result := 1; // focus window if (Windows.GetFocus <> Window) and ((lWinControl = nil) or (lWinControl.CanFocus)) then Windows.SetFocus(Window); Exit; end; WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP: begin XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); case Msg of WM_LBUTTONUP: MouseButton := mbLeft; WM_MBUTTONUP: MouseButton := mbMiddle; WM_RBUTTONUP: MouseButton := mbRight; end; WParamShiftState := KeysToShiftState(WParam); //MsgKeyDataToShiftState CallbackMouseUp(WindowInfo, XPos, YPos, MouseButton, WParamShiftState); Result := 1; Exit; end; WM_MBUTTONDBLCLK: begin NotifyUserInput := True; PLMsg:=@LMMouse; with LMMouse Do begin Msg := LM_MBUTTONDBLCLK; XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); Keys := WParam; lEventX := XPos; lEventY := YPos; end; end; WM_MOUSEHOVER: begin NotifyUserInput := True; LMessage.Msg := LM_ENTER; end; WM_MOUSELEAVE: begin NotifyUserInput := True; LMessage.Msg := LM_LEAVE; end; WM_MOUSEMOVE: begin XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); if GetLCLClientBoundsOffset(WindowInfo, R) then begin Dec(XPos, R.Left); Dec(YPos, R.Top); end; WParamShiftState := KeysToShiftState(WParam); CallbackMouseMove(WindowInfo, XPos, YPos, WParamShiftState); Result := 1; Exit; end; WM_MOUSEWHEEL: begin NotifyUserInput := True; PLMsg:=@LMMouseEvent; with LMMouseEvent Do begin X := SmallInt(Lo(LParam)); Y := SmallInt(Hi(LParam)); // check if mouse cursor within this window, otherwise send message to window the mouse is hovering over P.X := X; P.Y := Y; lEventX := X; lEventY := Y; TargetWindow := TCDWidgetSet(WidgetSet).WindowFromPoint(P); if TargetWindow = HWND(nil) then exit; // the mousewheel message is for us // windows handles combobox's mousewheel messages if (lWinControl=nil) or (lWinControl.FCompStyle <> csComboBox) then begin Msg := LM_MOUSEWHEEL; Button := Lo(WParam); WheelDelta := SmallInt(Hi(WParam)); State := KeysToShiftState(Button); UserData := Pointer(GetWindowLong(Window, GWL_USERDATA)); WinProcess := false; end; end; end; {$IFDEF EnableWMDropFiles} WM_DROPFILES: begin LMessage.Msg := LM_DROPFILES; LMessage.WParam := WParam; LMessage.LParam := LParam; end; {$ENDIF} //TODO:LM_MOVEPAGE,LM_MOVETOROW,LM_MOVETOCOLUMN WM_NCACTIVATE: begin // do not allow main form to be deactivated if (Application <> nil) and (Application.MainForm <> nil) and Application.MainForm.HandleAllocated and (Window = Application.MainForm.Handle) and (WParam = 0) then begin WParam := 1; end; end; WM_NCHITTEST: begin if (lWinControl <> nil) then begin if (lWinControl.FCompStyle = csHintWindow) then begin LMessage.Result := HTTRANSPARENT; WinProcess := false; end; end; end; WM_NCLBUTTONDOWN: begin NotifyUserInput := True; //DebugLn('Trace:WindowProc - Got WM_NCLBUTTONDOWN'); end; WM_PAINT: begin SendPaintMessage(HDC(WParam)); // SendPaintMessage sets winprocess to false end; WM_PRINTCLIENT: begin if ((LParam and PRF_CLIENT) = PRF_CLIENT) and (lWinControl <> nil) then SendPaintMessage(HDC(WParam)); end; WM_PASTE: begin LMessage.Msg := LM_PASTE; end; WM_RBUTTONDBLCLK: begin NotifyUserInput := True; PLMsg:=@LMMouse; with LMMouse Do begin Msg := LM_RBUTTONDBLCLK; XPos := SmallInt(Lo(LParam)); YPos := SmallInt(Hi(LParam)); Keys := WParam; end; end; WM_CONTEXTMENU: begin {$ifndef WinCE} WinProcess := false; NotifyUserInput := True; PLMsg := @LMContextMenu; with LMContextMenu do begin Msg := LM_CONTEXTMENU; XPos := GET_X_LPARAM(LParam); YPos := GET_Y_LPARAM(LParam); hWnd := Window; Result := 0; end; {$endif} end; WM_SETCURSOR: begin HandleSetCursor; end; WM_SETFOCUS: begin {$ifdef DEBUG_CARET} DebugLn('WM_SETFOCUS received for window ', IntToHex(Window, 8)); {$endif} // handle feature mouse-click, setfocus, mouse-click -> double-click if (Window <> MouseDownWindow) and (MouseDownFocusStatus <> mfNone) then begin MouseDownFocusStatus := mfFocusChanged; MouseDownFocusWindow := Window; end; LMessage.Msg := LM_SETFOCUS; if (lWinControl <> nil) and (lWinControl.FCompStyle = csEdit) then Windows.SendMessage(Window, EM_SETSEL, 0, -1); end; WM_SHOWWINDOW: begin //DebugLn('Trace:WindowProc - Got WM_SHOWWINDOW'); with TLMShowWindow(LMessage) Do begin Msg := LM_SHOWWINDOW; Show := WParam <> 0; Status := LParam; end; if assigned(lWinControl) and ((WParam<>0) or not lWinControl.Visible) and ((WParam=0) or lWinControl.Visible) and (Application<>nil) and (lWinControl=Application.MainForm) then begin if WParam=0 then Flags := SW_HIDE else Flags := SW_SHOWNOACTIVATE; Windows.ShowWindow(TCDWidgetSet(WidgetSet).FAppHandle, Flags); end; end; WM_SYSCHAR: begin PLMsg:=@LMChar; with LMChar Do begin Msg := CN_SYSCHAR; KeyData := LParam; CharCode := Word(WParam); Result := 0; //DebugLn(Format('WM_CHAR KeyData= %d CharCode= %d ',[KeyData,CharCode])); end; WinProcess := false; end; WM_SYSCOMMAND: begin HandleSysCommand; end; WM_SYSKEYDOWN: begin NotifyUserInput := True; PLMsg:=@LMKey; with LMKey Do begin Msg := CN_SYSKEYDOWN; KeyData := LParam; CharCode := Word(WParam); Result := 0; end; WinProcess := false; end; WM_SYSKEYUP: begin NotifyUserInput := True; PLMsg:=@LMKey; with LMKey Do begin Msg := CN_SYSKEYUP; KeyData := LParam; CharCode := Word(WParam); Result := 0; end; WinProcess := false; end; WM_TIMER: begin LMessage.Msg := LM_TIMER; LMessage.WParam := WParam; LMessage.LParam := LParam; end; WM_WINDOWPOSCHANGED: begin with TLMWindowPosMsg(LMessage) Do begin Msg := LM_WINDOWPOSCHANGED; Unused := WParam; WindowPos := PWindowPos(LParam); end; // cross-interface compatible: complete invalidate on resize if (PWindowPos(LParam)^.flags and SWP_NOSIZE) = 0 then Windows.InvalidateRect(Window, nil, true); end; { WM_LCL_SOCK_ASYNC: begin if (Window = TWinCEWidgetSet(WidgetSet).AppHandle) and Assigned(TWinCEWidgetSet(WidgetSet).FOnAsyncSocketMsg) then exit(TWinCEWidgetSet(WidgetSet).FOnAsyncSocketMsg(WParam, LParam)) end;} {$ifdef wince} WM_HOTKEY: begin // Implements back-key sending to edits, instead of hiding the form // See http://bugs.freepascal.org/view.php?id=16699 {if HIWORD(lParam) = VK_ESCAPE then begin SHSendBackToFocusWindow(Msg, wParam, lParam); Exit; end;} end; {$endif} else // pass along user defined messages if Msg >= WM_USER then begin LMessage.Msg := Msg; LMessage.WParam := WParam; LMessage.LParam := LParam; WinProcess := false; end; end; {$ifdef MSG_DEBUG} DebugLn('Trace:WindowProc - End Case Msg of'); {$endif} if WinProcess Then begin {$ifdef MSG_DEBUG} DebugLn('Trace:WindowProc - if WinProcess Then'); {$endif} PLMsg^.Result := CallDefaultWindowProc(Window, Msg, WParam, LParam); WinProcess := false; {$ifdef MSG_DEBUG} DebugLn('Trace:WindowProc - End if WinProcess Then'); {$endif} end; case Msg of WM_MOVE: begin {$ifndef WinCE} PLMsg:=@LMMove; with LMMove Do begin Msg := LM_MOVE; // MoveType := WParam; WParam is not defined! MoveType := Move_SourceIsInterface; if GetWindowLong(Window, GWL_STYLE) and WS_CHILD = 0 then begin WindowPlacement.length := SizeOf(WindowPlacement); if IsIconic(Window) and GetWindowPlacement(Window, @WindowPlacement) then begin with WindowPlacement.rcNormalPosition do begin XPos := Left; YPos := Top; end; end else if Windows.GetWindowRect(Window, @R) then begin XPos := R.Left; YPos := R.Top; end else Msg := LM_NULL; end else begin if LCLIntf.GetWindowRelativePosition(HWND(WindowInfo), NewLeft, NewTop) then begin XPos := NewLeft; YPos := NewTop; end else Msg := LM_NULL; end; if lWinControl <> nil then begin {$IFDEF VerboseSizeMsg} DebugLn('Win32CallBack WM_MOVE ', dbgsName(lWinControl), ' NewPos=',dbgs(XPos),',',dbgs(YPos)); {$ENDIF} if (lWinControl.Left = XPos) and (lWinControl.Top = YPos) then Exit; end; end; {$endif} end; WM_SIZE: begin with TLMSize(LMessage) do begin Msg := LM_SIZE; SizeType := WParam or Size_SourceIsInterface; if Window = CDWidgetSet.AppHandle then begin if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then begin lWinControl := Application.MainForm; Window := Application.MainFormHandle; end; end; LCLIntf.GetWindowSize(HWND(WindowInfo), NewWidth, NewHeight); Width := NewWidth; Height := NewHeight; if Assigned(lWinControl) then begin {$IFDEF VerboseSizeMsg} GetClientRect(Window,R); DebugLn('Win32Callback: WM_SIZE '+ dbgsName(lWinControl)+ ' NewSize=', dbgs(Width)+','+dbgs(Height)+ ' HasVScroll='+dbgs((GetWindowLong(Window, GWL_STYLE) and WS_VSCROLL) <> 0)+ ' HasHScroll='+dbgs((GetWindowLong(Window, GWL_STYLE) and WS_HSCROLL) <> 0)+ ' OldClientSize='+dbgs(lWinControl.CachedClientWidth)+','+dbgs(lWinControl.CachedClientHeight)+ ' NewClientSize='+dbgs(R.Right)+','+dbgs(R.Bottom)); {$ENDIF} if (lWinControl.Width <> Width) or (lWinControl.Height <> Height) or lWinControl.ClientRectNeedsInterfaceUpdate then lWinControl.DoAdjustClientRectChange else // If we get form size message then we probably changed it state // (minimized/maximized -> normal). Form adjust its clientrect in the // second WM_SIZE but WM_MOVE also updates clientrect without adjustment // thus we need to call DoAdjustClientRectChange. It is safe since this // methods checks whether it need to adjust something really. if (lWinControl is TCustomForm) and (lWinControl.Parent = nil) and (WParam = Size_Restored) then lWinControl.DoAdjustClientRectChange(False); end; end; end; {WM_ENDSESSION: begin if (Application<>nil) and (TWinCEWidgetSet(WidgetSet).AppHandle=Window) and (WParam>0) and (LParam=0) then begin LMessage.Msg := LM_NULL; // no need to go through delivermessage Application.IntfEndSession(); LMessage.Result := 0; end; end;} {WM_QUERYENDSESSION: begin if (Application<>nil) and (TWinCEWidgetSet(WidgetSet).AppHandle=Window) and (LParam=0) then begin LMessage.Msg := LM_NULL; // no need to go through delivermessage CancelEndSession := LMessage.Result=0; Application.IntfQueryEndSession(CancelEndSession); if CancelEndSession then LMessage.Result := 0 else LMessage.Result := 1; end; end;} end; // convert from wince client to lcl client pos. // // hack to prevent GetLCLClientBoundsOffset from changing mouse client // coordinates for TScrollingWinControls, this is required in // IsControlMouseMsg and ControlAtPos where unscrolled client coordinates // are expected. if (PLMsg = @LMMouseMove) and not (lWinControl is TScrollingWinControl) then begin if GetLCLClientBoundsOffset(WindowInfo, R) then begin Dec(LMMouseMove.XPos, R.Left); Dec(LMMouseMove.YPos, R.Top); end; end else if (PLMsg = @LMMouse) and not (lWinControl is TScrollingWinControl) then begin if GetLCLClientBoundsOffset(WindowInfo, R) then begin Dec(LMMouse.XPos, R.Left); Dec(LMMouse.YPos, R.Top); end; end; // application processing if NotifyUserInput then NotifyApplicationUserInput(lWinControl, PLMsg^.Msg); if (lWinControl <> nil) and (PLMsg^.Msg <> LM_NULL) then begin if (lEventX < 0) or (lEventY < 0) then begin DeliverMessage(lWinControl, PLMsg^); end else begin lEventReceiver := FindControlWhichReceivedEvent( TCustomForm(lWinControl), GetCDWinControlList(TCustomForm(lWinControl)), lEventX, lEventY); DeliverMessage(lEventReceiver, PLMsg^); end; end; // respond to result of LCL handling the message case PLMsg^.Msg of LM_ERASEBKGND, LM_SETCURSOR, LM_RBUTTONUP: begin if PLMsg^.Result = 0 then WinProcess := true; end; CN_CHAR, CN_SYSCHAR: begin // if key not yet processed, let windows process it WinProcess := LMChar.Result = 0; if (LMChar.Result=1) or (OrgCharCode<>LMChar.CharCode) then WParam := Word(WideChar(Char(LMChar.CharCode))); // WParam := LMChar.CharCode; end; CN_KEYDOWN, CN_KEYUP, CN_SYSKEYDOWN, CN_SYSKEYUP: begin // if key not yet processed, let windows process it WinProcess := LMKey.Result = 0; WParam := LMKey.CharCode; end; else case Msg of WM_LBUTTONDOWN, WM_LBUTTONUP: begin if MouseDownFocusStatus = mfFocusSense then MouseDownFocusStatus := mfNone; end; WM_NCDESTROY: begin WindowInfo.Free; WindowInfo := nil; end; end; end; if WinProcess then begin PLMsg^.Result := CallDefaultWindowProc(Window, Msg, WParam, LParam); case Msg of WM_CHAR, WM_KEYDOWN, WM_KEYUP, WM_SYSCHAR, WM_SYSKEYDOWN, WM_SYSKEYUP: begin PLMsg^.Result := 0; case Msg of WM_CHAR: begin // if want chars, then handled already PLMsg^.Result := CallDefaultWindowProc(Window, WM_GETDLGCODE, WParam, 0) and DLGC_WANTCHARS; LMChar.CharCode := Word(WParam); LMChar.Msg := LM_CHAR; end; WM_SYSCHAR: begin LMChar.CharCode := Word(WParam); LMChar.Msg := LM_SYSCHAR; end; WM_KEYDOWN: begin LMKey.CharCode := Word(WParam); LMKey.Msg := LM_KEYDOWN; end; WM_KEYUP: begin LMKey.CharCode := Word(WParam); LMKey.Msg := LM_KEYUP; end; WM_SYSKEYDOWN: begin LMKey.CharCode := Word(WParam); LMKey.Msg := LM_SYSKEYDOWN; end; WM_SYSKEYUP: begin LMKey.CharCode := Word(WParam); LMKey.Msg := LM_SYSKEYUP; end; end; // we cannot tell for sure windows didn't want the key // for WM_CHAR check WM_GETDLGCODE/DLGC_WANTCHARS // winapi too inconsistent about return value if PLMsg^.Result = 0 then DeliverMessage(lWinControl, PLMsg^); { // handle the hardware back key (= VK_ESCAPE) for edit controls // It should work as the backspace if (PLMsg^.Result = 0) and (Msg = WM_KEYDOWN) and (WParam = VK_ESCAPE) {and (GetKeyState(VK_CONTROL) >= 0) and (GetKeyState(VK_MENU) >= 0)} then begin if (WndClassName(Window) = EditClsName) then begin Windows.SendMessage(Window, WM_KEYDOWN, VK_BACK, -1); end; end;} end; end; end; // ignore WM_(SYS)CHAR message if LCL handled WM_(SYS)KEYDOWN if ((Msg = WM_KEYDOWN) or (Msg = WM_SYSKEYDOWN)) then begin if (PLMsg^.Result <> 0) then begin IgnoreNextCharWindow := Window; end else begin // stop ignoring if KEYUP has come by (not all keys generate CHAR) // assume WM_CHAR is always preceded by WM_KEYDOWN IgnoreNextCharWindow := 0; end; end; { LMMouseEvent and LMInsertText have no Result field } if PLMsg = @LMScroll then Result := LMScroll.Result else if PLMsg = @LMKey then Result := LMKey.Result else if PLMsg = @LMChar then Result := LMChar.Result else if PLMsg = @LMMouse then Result := LMMouse.Result else if PLMsg = @LMMouseMove then Result := LMMouseMove.Result else if PLMsg = @LMMove then Result := LMMove.Result else if PLMsg = @LMNotify then Result := LMNotify.Result else if PLMsg = @LMMouseEvent then Result := 1 else Result := PLMsg^.Result; //DebugLn('Trace:WindowProc - Exit'); end; {------------------------------------------------------------------------------ Procedure: TimerCallBackProc Params: window_hnd - handle of window for timer message, not set in this implementation msg - WM_TIMER message idEvent - timer identifier dwTime - current system time Calls the timerfunction in the Timer Object in the LCL ------------------------------------------------------------------------------} procedure TimerCallBackProc(window_hwnd : hwnd; msg :UINT; idEvent: UINT_PTR; dwTime: DWORD); {$if defined(win32) or defined(win64)}stdcall{$else}cdecl{$endif}; Var TimerInfo: PWinCETimerInfo; n: Integer; begin n := FTimerData.Count; while (n>0) do begin dec(n); TimerInfo := FTimerData[n]; if TimerInfo^.TimerID=idEvent then begin TimerInfo^.TimerFunc; break; end; end; end;