1{ $Id: gtkwscontrols.pp 57164 2018-01-27 18:12:35Z ondrej $} 2{ 3 ***************************************************************************** 4 * GtkWSControls.pp * 5 * ---------------- * 6 * * 7 * * 8 ***************************************************************************** 9 10 ***************************************************************************** 11 This file is part of the Lazarus Component Library (LCL) 12 13 See the file COPYING.modifiedLGPL.txt, included in this distribution, 14 for details about the license. 15 ***************************************************************************** 16} 17unit GtkWSControls; 18 19{$mode objfpc}{$H+} 20 21{$DEFINE UseGDKErrorTrap} 22 23interface 24 25uses 26 {$IFDEF GTK2} 27 Gtk2, Glib2, Gdk2, Gdk2Pixbuf, 28 {$ELSE} 29 Gtk, Glib, Gdk, 30 {$ENDIF} 31 SysUtils, Classes, Controls, LMessages, InterfaceBase, 32 WSControls, WSLCLClasses, WSProc, 33 Graphics, ComCtrls, Forms, LCLType, 34 GtkDef, GTKExtra, GtkDebug; 35 36type 37 38 { TGtkWSDragImageListResolution } 39 40 TGtkWSDragImageListResolution = class(TWSDragImageListResolution) 41 published 42 class function BeginDrag(const ADragImageList: TDragImageListResolution; Window: HWND; AIndex, X, Y: Integer): Boolean; override; 43 class function DragMove(const ADragImageList: TDragImageListResolution; X, Y: Integer): Boolean; override; 44 class procedure EndDrag(const ADragImageList: TDragImageListResolution); override; 45 class function HideDragImage(const ADragImageList: TDragImageListResolution; 46 ALockedWindow: HWND; DoUnLock: Boolean): Boolean; override; 47 class function ShowDragImage(const ADragImageList: TDragImageListResolution; 48 ALockedWindow: HWND; X, Y: Integer; DoLock: Boolean): Boolean; override; 49 end; 50 51 { TGtkWSControl } 52 53 TGtkWSControl = class(TWSControl) 54 published 55 end; 56 57 58 { TGtkWSWinControl } 59 60 TGtkWSWinControl = class(TWSWinControl) 61 private 62 protected 63 {$IFDEF GTK1} 64 class procedure SetCCCallbacks(const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo); 65 {$ENDIF} 66 public 67 // Internal public 68 class procedure SetCallbacks(const AGTKObject: PGTKObject; const AComponent: TComponent); 69 published 70 {$IFDEF GTK1} 71 class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): HWND; override; 72 {$ENDIF} 73 class procedure AddControl(const AControl: TControl); override; 74 class function CanFocus(const AWinControl: TWinControl): Boolean; override; 75 class procedure ConstraintsChange(const AWinControl: TWinControl); override; 76 class procedure DestroyHandle(const AWinControl: TWinControl); override; 77 class procedure Invalidate(const AWinControl: TWinControl); override; 78 79 class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override; 80 81 class procedure SetBorderStyle(const AWinControl: TWinControl; const ABorderStyle: TBorderStyle); override; 82 class procedure SetBounds(const AWinControl: TWinControl; const ALeft, ATop, AWidth, AHeight: Integer); override; 83 class procedure SetChildZPosition(const AWinControl, AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList); override; 84 class procedure SetColor(const AWinControl: TWinControl); override; 85 class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override; 86 class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override; 87 class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override; 88 class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override; 89 class procedure SetText(const AWinControl: TWinControl; const AText: string); override; 90 class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); override; 91 92 class procedure PaintTo(const AWinControl: TWinControl; ADC: HDC; X, Y: Integer); override; 93 class procedure ShowHide(const AWinControl: TWinControl); override; 94 end; 95 96 { TGtkWSGraphicControl } 97 98 TGtkWSGraphicControl = class(TWSGraphicControl) 99 published 100 end; 101 102 { TGtkWSCustomControl } 103 104 TGtkWSCustomControl = class(TWSCustomControl) 105 published 106 end; 107 108 { TGtkWSImageList } 109 110 TGtkWSImageList = class(TWSImageList) 111 published 112 end; 113 114 { TGtkWSBaseScrollingWinControl } 115 { 116 TGtkWSBaseScrollingWinControl is a shared gtk only base implementation of 117 all scrolling widgets, like TListView, TScrollingWinControl etc. 118 It only creates a scrolling widget and handles the LM_HSCROLL and LM_VSCROLL 119 messages 120 } 121 PBaseScrollingWinControlData = ^TBaseScrollingWinControlData; 122 TBaseScrollingWinControlData = record 123 HValue: Integer; 124 HScroll: PGTKWidget; 125 VValue: Integer; 126 VScroll: PGTKWidget; 127 end; 128 129 { TGtkWSBaseScrollingWinControl } 130 131 TGtkWSBaseScrollingWinControl = class(TWSWinControl) 132 public 133 class procedure SetCallbacks(const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo); virtual; 134 published 135 class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): HWND; override; 136 end; 137 138procedure GtkWindowShowModal(GtkWindow: PGtkWindow); 139function GetWidgetHAdjustment(AWidget: PGTKWidget): PGTKAdjustment; 140function GetWidgetVAdjustment(AWidget: PGTKWidget): PGTKAdjustment; 141 142implementation 143 144uses 145 GTKWSPrivate, 146 {$ifdef gtk1} 147 GTK1WSPrivate, 148 {$endif} 149 GtkInt, gtkglobals, gtkproc, GTKWinApiWindow, 150 StdCtrls, LCLProc, LCLIntf; 151 152 153 154{ TGtkWSWinControl } 155 156type 157 TWinControlHack = class(TWinControl) 158 end; 159 160class procedure TGtkWSWinControl.AddControl(const AControl: TControl); 161var 162 AParent: TWinControl; 163 ParentWidget: PGTKWidget; 164 ChildWidget: PGTKWidget; 165 pFixed: PGTKWidget; 166begin 167 {$IFDEF OldToolBar} 168 if (AControl.Parent is TToolbar) then 169 exit; 170 {$ENDIF} 171 172 AParent := TWinControl(AControl).Parent; 173 //debugln('LM_AddChild: ',TWinControl(Sender).Name,' ',dbgs(AParent<>nil)); 174 if not Assigned(AParent) then 175 Assert(true, Format('Trace: [TGtkWSWinControl.AddControl] %s --> Parent is not assigned', [AControl.ClassName])) 176 else 177 begin 178 //DebugLn(Format('Trace: [TGtkWSWinControl.AddControl] %s --> Calling Add Child: %s', [AParent.ClassName, AControl.ClassName])); 179 ParentWidget := Pgtkwidget(AParent.Handle); 180 pFixed := GetFixedWidget(ParentWidget); 181 if pFixed <> ParentWidget then 182 begin 183 // parent changed for child 184 ChildWidget := PGtkWidget(TWinControl(AControl).Handle); 185 FixedPutControl(pFixed, ChildWidget, AControl.Left, AControl.Top); 186 RegroupAccelerator(ChildWidget); 187 end; 188 end; 189end; 190 191class function TGtkWSWinControl.CanFocus(const AWinControl: TWinControl): Boolean; 192var 193 Widget, FocusWidget: PGtkWidget; 194begin 195 if AWinControl.HandleAllocated then 196 begin 197 Widget := PGtkWidget(AWinControl.Handle); 198 FocusWidget := FindFocusWidget(Widget); 199 Result := (FocusWidget <> nil) and GTK_WIDGET_CAN_FOCUS(FocusWidget); 200 end else 201 Result := False; 202end; 203 204class procedure TGtkWSWinControl.ConstraintsChange(const AWinControl: TWinControl); 205var 206 Widget: PGtkWidget; 207 Geometry: TGdkGeometry; 208begin 209 Widget := PGtkWidget(AWinControl.Handle); 210 if (Widget <> nil) and (GtkWidgetIsA(Widget, gtk_window_get_type)) then 211 begin 212 with Geometry do 213 begin 214 if AWinControl.Constraints.MinWidth > 0 then 215 min_width := AWinControl.Constraints.MinWidth 216 else 217 min_width := 1; 218 if AWinControl.Constraints.MaxWidth > 0 then 219 max_width := AWinControl.Constraints.MaxWidth 220 else 221 max_width := 32767; 222 if AWinControl.Constraints.MinHeight > 0 then 223 min_height := AWinControl.Constraints.MinHeight 224 else 225 min_height := 1; 226 if AWinControl.Constraints.MaxHeight > 0 then 227 max_height := AWinControl.Constraints.MaxHeight 228 else 229 max_height := 32767; 230 231 base_width := AWinControl.Width; 232 base_height := AWinControl.Height; 233 width_inc := 1; 234 height_inc := 1; 235 min_aspect := 0; 236 max_aspect := 1; 237 end; 238 //debugln('TGtkWSWinControl.ConstraintsChange A ',GetWidgetDebugReport(Widget),' max=',dbgs(Geometry.max_width),'x',dbgs(Geometry.max_height)); 239 gtk_window_set_geometry_hints(PGtkWindow(Widget), nil, @Geometry, 240 GDK_HINT_MIN_SIZE or GDK_HINT_MAX_SIZE); 241 end; 242end; 243 244class procedure TGtkWSWinControl.DestroyHandle(const AWinControl: TWinControl); 245begin 246 //DebugLn('TGtkWSWinControl.DestroyHandle ',DbgSName(AWinControl)); 247 TGtkWidgetSet(WidgetSet).DestroyLCLComponent(AWinControl); 248end; 249 250class function TGtkWSWinControl.GetText(const AWinControl: TWinControl; var AText: String): Boolean; 251var 252 CS: PChar; 253 Handle: HWND; 254begin 255 Result := False; 256 if not WSCheckHandleAllocated(AWinControl, 'GetText') 257 then Exit; 258 259 Result := true; 260 Handle := AWinControl.Handle; 261 case AWinControl.fCompStyle of 262 csComboBox: 263 begin 264 AText := StrPas(gtk_entry_get_text(PGtkEntry(PGtkCombo(Handle)^.entry))); 265 end; 266 267 csEdit, csSpinEdit: 268 AText:= StrPas(gtk_entry_get_text(PgtkEntry(Handle))); 269 270 csMemo : begin 271 CS := gtk_editable_get_chars(PGtkOldEditable( 272 GetWidgetInfo(Pointer(Handle), True)^.CoreWidget), 0, -1); 273 AText := StrPas(CS); 274 g_free(CS); 275 end; 276 else 277 Result := false; 278 end; 279end; 280 281class procedure TGtkWSWinControl.Invalidate(const AWinControl: TWinControl); 282begin 283 if not WSCheckHandleAllocated(AWinControl, 'Invalidate') 284 then Exit; 285 286 //DebugLn('Trace:Trying to invalidate window... !!!'); 287 gtk_widget_queue_draw(PGtkWidget(AWinControl.Handle)); 288end; 289 290class procedure TGtkWSWinControl.ShowHide(const AWinControl: TWinControl); 291begin 292 // other methods use ShowHide also, can't move code 293 TGtkWidgetSet(WidgetSet).SetVisible(AWinControl, AWinControl.HandleObjectShouldBeVisible); 294end; 295 296class procedure TGtkWSWinControl.SetBounds(const AWinControl: TWinControl; 297 const ALeft, ATop, AWidth, AHeight: Integer); 298begin 299 if not WSCheckHandleAllocated(AWinControl, 'SetBounds') 300 then Exit; 301 302 ResizeHandle(AWinControl); 303end; 304 305class procedure TGtkWSWinControl.SetBorderStyle(const AWinControl: TWinControl; 306 const ABorderStyle: TBorderStyle); 307var 308 Widget: PGtkWidget; 309begin 310 if not WSCheckHandleAllocated(AWinControl, 'SetBorderStyle') 311 then Exit; 312 313 Widget := PGtkWidget(AWinControl.Handle); 314 if GtkWidgetIsA(Widget, GTKAPIWidget_GetType) then 315 GTKAPIWidget_SetShadowType(PGTKAPIWidget(Widget), BorderStyleShadowMap[ABorderStyle]) 316 else 317 if GTK_IS_FRAME(Widget) then 318 gtk_frame_set_shadow_type(PGtkFrame(Widget), BorderStyleShadowMap[ABorderStyle]) 319 else 320 if GTK_IS_VIEWPORT(Widget) then 321 gtk_viewport_set_shadow_type(PGtkViewport(Widget), BorderStyleShadowMap[ABorderStyle]); 322end; 323 324{$IFDEF GTK1} 325class procedure TGtkWSWinControl.SetCCCallbacks(const AWidget: PGtkWidget; 326 const AWidgetInfo: PWidgetInfo); 327begin 328 SetCallbacks(PGtkObject(AWidget), TComponent(AWidgetInfo^.LCLObject)); 329 with TGTKWidgetSet(Widgetset) do 330 begin 331 SetCallback(LM_HSCROLL, PGtkObject(AWidget), AWidgetInfo^.LCLObject); 332 SetCallback(LM_VSCROLL, PGtkObject(AWidget), AWidgetInfo^.LCLObject); 333 end; 334end; 335{$ENDIF} 336 337class procedure TGtkWSWinControl.SetCallbacks(const AGTKObject: PGTKObject; 338 const AComponent: TComponent); 339begin 340 GtkWidgetSet.SetCommonCallbacks(AGtkObject, AComponent); 341end; 342 343{$IFDEF GTK1} 344class function TGtkWSWinControl.CreateHandle(const AWinControl: TWinControl; 345 const AParams: TCreateParams): HWND; 346var 347 Widget: PGtkWidget; 348 WidgetInfo: PWidgetInfo; 349 Allocation: TGTKAllocation; 350begin 351 Widget := TGtkWidgetset(Widgetset).CreateAPIWidget(AWinControl); 352 {$IFDEF DebugLCLComponents} 353 DebugGtkWidgets.MarkCreated(Widget, dbgsName(AWinControl)); 354 {$ENDIF} 355 356 Result := THandle(PtrUInt(Widget)); 357 if Result = 0 then Exit; 358 359 WidgetInfo := GetWidgetInfo(Widget); // Widget info already created in CreateAPIWidget 360 WidgetInfo^.Style := AParams.Style; 361 WidgetInfo^.ExStyle := AParams.ExStyle; 362 WidgetInfo^.WndProc := PtrUInt(AParams.WindowClass.lpfnWndProc); 363 364 // set allocation 365 Allocation.X := AParams.X; 366 Allocation.Y := AParams.Y; 367 Allocation.Width := AParams.Width; 368 Allocation.Height := AParams.Height; 369 gtk_widget_size_allocate(Widget, @Allocation); 370 371 Set_RC_Name(AWinControl, Widget); 372 SetCCCallbacks(Widget, WidgetInfo); 373end; 374{$ENDIF} 375 376class procedure TGtkWSWinControl.SetChildZPosition( 377 const AWinControl, AChild: TWinControl; 378 const AOldPos, ANewPos: Integer; const AChildren: TFPList); 379var 380 n: Integer; 381 child: TWinControlHack; 382begin 383 if not WSCheckHandleAllocated(AWincontrol, 'SetChildZPosition') 384 then Exit; 385 386 if ANewPos < AChildren.Count div 2 387 then begin 388 // move down (and others below us) 389 for n := ANewPos downto 0 do 390 begin 391 child := TWinControlHack(AChildren[n]); 392 if child.HandleAllocated 393 then TGtkPrivateWidgetClass(child.WidgetSetClass.WSPrivate). 394 SetZPosition(child, wszpBack); 395 end; 396 end 397 else begin 398 // move up (and others above us) 399 for n := ANewPos to AChildren.Count - 1 do 400 begin 401 child := TWinControlHack(AChildren[n]); 402 if child.HandleAllocated 403 then TGtkPrivateWidgetClass(child.WidgetSetClass.WSPrivate).SetZPosition(child, wszpFront); 404 end; 405 end; 406end; 407 408class procedure TGtkWSWinControl.SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); 409var 410 WidgetInfo: PWidgetInfo; 411begin 412 if not WSCheckHandleAllocated(AWinControl, 'SetCursor') 413 then Exit; 414 415 WidgetInfo := GetWidgetInfo(Pointer(AWinControl.Handle)); 416 if (WidgetInfo^.ControlCursor = ACursor) and 417 (WidgetInfo^.DefaultCursor <> HCursor(-1)) then Exit; 418 if ACursor <> Screen.Cursors[crDefault] then 419 WidgetInfo^.ControlCursor := ACursor 420 else 421 begin 422 if WidgetInfo^.DefaultCursor = HCursor(-1) then 423 TGtkPrivateWidgetClass(AWinControl.WidgetSetClass.WSPrivate).SetDefaultCursor(WidgetInfo); 424 WidgetInfo^.ControlCursor := WidgetInfo^.DefaultCursor; 425 end; 426 TGtkPrivateWidgetClass(AWinControl.WidgetSetClass.WSPrivate).UpdateCursor(WidgetInfo); 427end; 428 429class procedure TGtkWSWinControl.SetFont(const AWinControl: TWinControl; 430 const AFont: TFont); 431var 432 Widget: PGtkWidget; 433begin 434 if not WSCheckHandleAllocated(AWinControl, 'SetFont') 435 then Exit; 436 437 Widget := PGtkWidget(AWinControl.Handle); 438 if GtkWidgetIsA(Widget, GTKAPIWidget_GetType) then 439 exit; 440 441 //DebugLn('TGtkWSWinControl.SetFont ',DbgSName(AWinControl)); 442 GtkWidgetSet.SetWidgetFont(Widget, AFont); 443 GtkWidgetSet.SetWidgetColor(Widget, AFont.Color, clNone, 444 [GTK_STATE_NORMAL,GTK_STATE_ACTIVE, 445 GTK_STATE_PRELIGHT,GTK_STATE_SELECTED 446 {$IFDEF GTK2},GTK_STYLE_TEXT{$ENDIF}]); 447end; 448 449class procedure TGtkWSWinControl.SetPos(const AWinControl: TWinControl; 450 const ALeft, ATop: Integer); 451var 452 Widget: PGtkWidget; 453 Allocation: TGTKAllocation; 454begin 455 if not WSCheckHandleAllocated(AWinControl, 'SetPos') 456 then Exit; 457 {$IFDEF VerboseSizeMsg} 458 DebugLn(['TGtkWSWinControl.SetPos ',DbgSName(AWinControl),' ',ALeft,',',ATop]); 459 {$ENDIF} 460 461 Widget := PGtkWidget(AWinControl.Handle); 462 Allocation.X := gint16(ALeft); 463 Allocation.Y := gint16(ATop); 464 Allocation.Width := guint16(Widget^.Allocation.Width); 465 Allocation.Height := guint16(Widget^.Allocation.Height); 466 gtk_widget_size_allocate(Widget, @Allocation);// Beware: this triggers callbacks 467end; 468 469class procedure TGtkWSWinControl.SetSize(const AWinControl: TWinControl; 470 const AWidth, AHeight: Integer); 471var 472 Widget: PGtkWidget; 473 Allocation: TGTKAllocation; 474begin 475 if not WSCheckHandleAllocated(AWinControl, 'SetSize') 476 then Exit; 477 {$IFDEF VerboseSizeMsg} 478 DebugLn(['TGtkWSWinControl.SetSize ',DbgSName(AWinControl),' ',AWidth,',',AHeight]); 479 {$ENDIF} 480 481 Widget := PGtkWidget(AWinControl.Handle); 482 Allocation.X := Widget^.Allocation.X; 483 Allocation.Y := Widget^.Allocation.Y; 484 Allocation.Width := guint16(AWidth); 485 Allocation.Height := guint16(AHeight); 486 gtk_widget_size_allocate(Widget, @Allocation);// Beware: this triggers callbacks 487end; 488 489class procedure TGtkWSWinControl.SetColor(const AWinControl: TWinControl); 490begin 491 if not WSCheckHandleAllocated(AWinControl, 'SetColor') 492 then Exit; 493 494 if ((csOpaque in AWinControl.ControlStyle) and 495 GtkWidgetIsA(pGtkWidget(AWinControl.handle),GTKAPIWidget_GetType)) then 496 Exit; 497 498 //DebugLn('TGtkWSWinControl.SetColor ',DbgSName(AWinControl)); 499 GtkWidgetSet.SetWidgetColor(PGtkWidget(AWinControl.Handle), 500 AWinControl.Font.Color, AWinControl.Color, 501 [GTK_STATE_NORMAL, GTK_STATE_ACTIVE, 502 GTK_STATE_PRELIGHT, GTK_STATE_SELECTED]); 503// GtkWidgetSet.setWidgetFont(pGtkWidget(AWinControl.handle),aWinControl.font); 504 UpdateWidgetStyleOfControl(AWinControl); 505end; 506 507class procedure TGtkWSWinControl.SetText(const AWinControl: TWinControl; 508 const AText: string); 509 510 procedure SetNotebookPageTabLabel; 511 var 512 NoteBookWidget: PGtkWidget; // the notebook 513 PageWidget: PGtkWidget; // the page (content widget) 514 TabWidget: PGtkWidget; // the tab (hbox containing a pixmap, a label 515 // and a close button) 516 TabLabelWidget: PGtkWidget; // the label in the tab 517 MenuWidget: PGtkWidget; // the popup menu (hbox containing a pixmap and 518 // a label) 519 MenuLabelWidget: PGtkWidget; // the label in the popup menu item 520 NewText: PChar; 521 begin 522 // dig through the hierachy to get the labels 523 NoteBookWidget:=PGtkWidget((AWinControl.Parent).Handle); 524 PageWidget:=PGtkWidget(AWinControl.Handle); 525 TabWidget:=gtk_notebook_get_tab_label(PGtkNoteBook(NotebookWidget), 526 PageWidget); 527 if TabWidget<>nil then 528 TabLabelWidget:=gtk_object_get_data(PGtkObject(TabWidget), 'TabLabel') 529 else 530 TabLabelWidget:=nil; 531 MenuWidget:=gtk_notebook_get_menu_label(PGtkNoteBook(NotebookWidget), 532 PageWidget); 533 if MenuWidget<>nil then 534 MenuLabelWidget:=gtk_object_get_data(PGtkObject(MenuWidget), 'TabLabel') 535 else 536 MenuLabelWidget:=nil; 537 // set new text 538 NewText:=PChar(AText); 539 if TabLabelWidget<>nil then 540 gtk_label_set_text(pGtkLabel(TabLabelWidget), NewText); 541 if MenuLabelWidget<>nil then 542 gtk_label_set_text(pGtkLabel(MenuLabelWidget), NewText); 543 end; 544 545var 546 P : Pointer; 547 aLabel, pLabel: pchar; 548begin 549 if not WSCheckHandleAllocated(AWinControl, 'SetText') 550 then Exit; 551 552 //TODO: create classprocedures for this in the corresponding classes 553 554 P := Pointer(AWinControl.Handle); 555 Assert(p <> nil, 'Trace:WARNING: [TGtkWidgetSet.SetLabel] --> got nil pointer'); 556 //DebugLn('Trace:Setting Str1 in SetLabel'); 557 pLabel := pchar(AText); 558 559 case AWinControl.fCompStyle of 560 csBitBtn, 561 csButton: DebugLn('[WARNING] Obsolete call to TGTKOBject.SetLabel for ', AWinControl.ClassName); 562 563{$IFDEF OldToolBar} 564 csToolButton: 565 with PgtkButton(P)^ do 566 begin 567 //aLabel := StrAlloc(Length(AnsiString(PLabel)) + 1); 568 aLabel := Ampersands2Underscore(PLabel); 569 Try 570 //StrPCopy(aLabel, AnsiString(PLabel)); 571 //Accel := Ampersands2Underscore(aLabel); 572 if gtk_bin_get_child(P) = nil then 573 begin 574 //DebugLn(Format('trace: [TGtkWidgetSet.SetLabel] %s has no child label', [AWinControl.ClassName])); 575 gtk_container_add(P, gtk_label_new(aLabel)); 576 end 577 else begin 578 //DebugLn(Format('trace: [TGtkWidgetSet.SetLabel] %s has child label', [AWinControl.ClassName])); 579 gtk_label_set_text(pgtkLabel( gtk_bin_get_child(P)), aLabel); 580 end; 581 //If Accel <> -1 then 582 AccelKey:=gtk_label_parse_uline(PGtkLabel( gtk_bin_get_child(P)), aLabel); 583 Accelerate(AWinControl,PGtkWidget(P),AccelKey,0,'clicked'); 584 Finally 585 StrDispose(aLabel); 586 end; 587 end; 588{$ENDIF OldToolBar} 589 590 csForm, 591 csFileDialog, csOpenFileDialog, csSaveFileDialog, csSelectDirectoryDialog, 592 csPreviewFileDialog, 593 csColorDialog, 594 csFontDialog: 595 if GtkWidgetIsA(p,gtk_window_get_type) then 596 gtk_window_set_title(pGtkWindow(p),PLabel); 597 598 csCheckBox, 599 csToggleBox, 600 csRadioButton: 601 begin 602 aLabel := Ampersands2Underscore(PLabel); 603 Try 604 gtk_label_set_text( 605 pGtkLabel(gtk_bin_get_child(PGtkBin(@PGTKToggleButton(p)^.Button))), 606 aLabel); 607 gtk_label_parse_uline(pGtkLabel(gtk_bin_get_child(PGtkBin(@PGTKToggleButton(p)^.Button))), 608 aLabel); 609 Finally 610 StrDispose(aLabel); 611 end; 612 end; 613 614 csEdit : begin 615 LockOnChange(PGtkObject(p),+1); 616 gtk_entry_set_text(pGtkEntry(P), pLabel); 617 LockOnChange(PGtkObject(p),-1); 618 end; 619 620 csSpinEdit : begin 621 LockOnChange(PGtkObject(p),+1); 622 gtk_entry_set_text(pGtkEntry(P), pLabel); 623 gtk_spin_button_update(PGtkSpinButton(p)); 624 LockOnChange(PGtkObject(p),-1); 625 end; 626 627 csMemo : begin 628 P:= GetWidgetInfo(P, True)^.CoreWidget; 629 //debugln('TGtkWSWinControl.SetText A ',dbgs(gtk_text_get_length(PGtkText(P))),' AText="',AText,'"'); 630 gtk_text_freeze(PGtkText(P)); 631 gtk_text_set_point(PGtkText(P), 0); 632 gtk_text_forward_delete(PGtkText(P), gtk_text_get_length(PGtkText(P))); 633 gtk_text_insert(PGtkText(P), nil, nil, nil, pLabel, -1); 634 gtk_text_thaw(PGtkText(P)); 635 //debugln('TGtkWSWinControl.SetText B ',dbgs(gtk_text_get_length(PGtkText(P)))); 636 end; 637 638 csPage: 639 SetNotebookPageTabLabel; 640 641 else 642 // DebugLn('WARNING: [TGtkWidgetSet.SetLabel] --> not handled for class ',Sender.ClassName); 643 end; 644 //DebugLn(Format('trace: [TGtkWidgetSet.SetLabel] %s --> END', [AWinControl.ClassName])); 645end; 646 647class procedure TGtkWSWinControl.SetShape(const AWinControl: TWinControl; 648 const AShape: HBITMAP); 649var 650 GtkWidget, FixedWidget: PGtkWidget; 651 GdkBitmap: PGDKBitmap; 652begin 653 if not WSCheckHandleAllocated(AWinControl, 'SetShape') then 654 Exit; 655 656 GtkWidget := PGtkWidget(AWinControl.Handle); 657 FixedWidget := GetFixedWidget(GtkWidget); 658 659 if AShape <> 0 then 660 begin 661 if GtkWidgetset.IsValidGDIObjectType(AShape, gdiBitmap) then 662 GdkBitmap := PGdiObject(AShape)^.GDIBitmapObject 663 else 664 GdkBitmap := nil; 665 end 666 else 667 GdkBitmap := nil; 668 669 gtk_widget_shape_combine_mask(GtkWidget, GdkBitmap, 0, 0); 670 if FixedWidget <> GtkWidget then 671 gtk_widget_shape_combine_mask(FixedWidget, GdkBitmap, 0, 0); 672end; 673 674{ 675 Paint control to X, Y point of device context. 676} 677class procedure TGtkWSWinControl.PaintTo(const AWinControl: TWinControl; 678 ADC: HDC; X, Y: Integer); 679var 680 DC: TGtkDeviceContext absolute ADC; 681 682 procedure PaintWindow(AWindow: PGdkWindow; AOffset: TPoint); 683 var 684 W, H: gint; 685 {$ifndef gtk1} 686 Pixbuf: PGdkPixbuf; 687 {$endif} 688 begin 689 gdk_window_get_size(AWindow, @W, @H); 690 {$ifdef gtk1} 691 gdk_window_copy_area(DC.Drawable, DC.GC, X, Y, AWindow, 692 AOffset.X, AOffset.Y, W, H); 693 {$else} 694 // for some reason gdk_window_copy_area does not work 695 Pixbuf := gdk_pixbuf_get_from_drawable(nil, AWindow, nil, 696 AOffset.X, AOffset.Y, 0, 0, W, H); 697 gdk_pixbuf_render_to_drawable(Pixbuf, DC.Drawable, DC.GC, 0, 0, X, Y, 698 -1, -1, GDK_RGB_DITHER_NONE, 0, 0); 699 gdk_pixbuf_unref(Pixbuf); 700 {$endif} 701 end; 702 703 procedure PaintWidget(AWidget: PGtkWidget); 704 var 705 AOffset: TPoint; 706 AWindow: PGdkWindow; 707 begin 708 AWindow := GetControlWindow(AWidget); 709 AOffset := Point(AWidget^.allocation.x, AWidget^.allocation.y); 710 711 if AWindow <> nil then 712 PaintWindow(AWindow, AOffset); 713 end; 714 715begin 716 if not WSCheckHandleAllocated(AWinControl, 'PaintTo') 717 then Exit; 718 PaintWidget(GetFixedWidget(PGtkWidget(AWinControl.Handle))); 719end; 720 721{ helper/common routines } 722 723procedure GtkWindowShowModal(GtkWindow: PGtkWindow); 724begin 725 if (GtkWindow=nil) then exit; 726 UnsetResizeRequest(PgtkWidget(GtkWindow)); 727 728 if ModalWindows=nil then ModalWindows:=TFPList.Create; 729 ModalWindows.Add(GtkWindow); 730 {$IFNDEF gtk_no_set_modal} 731 gtk_window_set_modal(GtkWindow, true); 732 {$ENDIF} 733 {$IFDEF Gtk1} 734 gtk_widget_show(PGtkWidget(GtkWindow)); 735 GDK_WINDOW_ACTIVATE(PGdkWindowPrivate(PGtkWidget(GtkWindow)^.window)); 736 {$ELSE} 737 gtk_window_present(GtkWindow); 738 {$ENDIF} 739 740 {$IFDEF VerboseTransient} 741 DebugLn('TGtkWidgetSet.ShowModal ',Sender.ClassName); 742 {$ENDIF} 743 TGtkWidgetSet(WidgetSet).UpdateTransientWindows; 744end; 745 746function GetWidgetHAdjustment(AWidget: PGTKWidget): PGTKAdjustment; 747begin 748 if GtkWidgetIsA(AWidget,GTK_TYPE_SCROLLED_WINDOW) then 749 Result:=gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(AWidget)) 750 {$IFDEF Gtk2} 751 else if GtkWidgetIsA(AWidget,GTK_TYPE_TREE_VIEW) then 752 Result:=gtk_tree_view_get_hadjustment(PGtkTreeView(AWidget)) 753 {$ENDIF} 754 else 755 Result:=nil; 756end; 757 758function GetWidgetVAdjustment(AWidget: PGTKWidget): PGTKAdjustment; 759begin 760 if GtkWidgetIsA(AWidget,GTK_TYPE_SCROLLED_WINDOW) then 761 Result:=gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(AWidget)) 762 {$IFDEF Gtk2} 763 else if GtkWidgetIsA(AWidget,GTK_TYPE_TREE_VIEW) then 764 Result:=gtk_tree_view_get_vadjustment(PGtkTreeView(AWidget)) 765 {$ENDIF} 766 else 767 Result:=nil; 768end; 769 770 771{ TGtkWSBaseScrollingWinControl } 772 773function GtkWSBaseScrollingWinControl_HValueChanged(AAdjustment: PGTKAdjustment; AInfo: PWidgetInfo): GBoolean; cdecl; 774var 775 ScrollingData: PBaseScrollingWinControlData; 776 Msg: TLMHScroll; 777 OldValue, V, U, L, StepI, PageI: Integer; 778 X, Y: GInt; 779 Mask: TGdkModifierType; 780begin 781 Result := CallBackDefaultReturn; 782 if AInfo^.ChangeLock > 0 then Exit; 783 784 ScrollingData := AInfo^.UserData; 785 786 // round values 787 V := Round(AAdjustment^.Value); 788 U := Round(AAdjustment^.Upper); 789 L := Round(AAdjustment^.Lower); 790 StepI := Round(AAdjustment^.Step_Increment); 791 PageI := Round(AAdjustment^.Page_Increment); 792 793 OldValue := ScrollingData^.HValue; 794 ScrollingData^.HValue := V; 795 796 // get keystates 797 Mask := 0; 798 if ScrollingData^.HScroll <> nil 799 then begin 800 {$IFDEF UseGDKErrorTrap} 801 BeginGDKErrorTrap; 802 {$ENDIF} 803 gdk_window_get_pointer(GetControlWindow(ScrollingData^.HScroll), @X, @Y, @Mask); 804 {$IFDEF UseGDKErrorTrap} 805 EndGDKErrorTrap; 806 {$ENDIF} 807 end; 808 809 Msg.msg := LM_HSCROLL; 810 // get scrollcode 811 if ssLeft in GTKEventStateToShiftState(Word(Mask)) 812 then Msg.ScrollCode := SB_THUMBTRACK 813 else if V <= L 814 then Msg.ScrollCode := SB_TOP 815 else if V >= U 816 then Msg.ScrollCode := SB_BOTTOM 817 else if V - OldValue = StepI 818 then Msg.ScrollCode := SB_LINERIGHT 819 else if OldValue - V = StepI 820 then Msg.ScrollCode := SB_LINELEFT 821 else if V - OldValue = PageI 822 then Msg.ScrollCode := SB_PAGERIGHT 823 else if OldValue - V = PageI 824 then Msg.ScrollCode := SB_PAGELEFT 825 else Msg.ScrollCode := SB_THUMBPOSITION; 826 Msg.Pos := V; 827 if V < High(Msg.SmallPos) 828 then Msg.SmallPos := V 829 else Msg.SmallPos := High(Msg.SmallPos); 830 Msg.ScrollBar := HWND(PtrUInt(ScrollingData^.HScroll)); 831 832 Result := (DeliverMessage(AInfo^.LCLObject, Msg) <> 0) xor CallBackDefaultReturn; 833end; 834 835function GtkWSBaseScrollingWinControl_VValueChanged(AAdjustment: PGTKAdjustment; AInfo: PWidgetInfo): GBoolean; cdecl; 836var 837 ScrollingData: PBaseScrollingWinControlData; 838 Msg: TLMHScroll; 839 OldValue, V, U, L, StepI, PageI: Integer; 840 X, Y: GInt; 841 Mask: TGdkModifierType; 842begin 843 Result := CallBackDefaultReturn; 844 if AInfo^.ChangeLock > 0 then Exit; 845 846 ScrollingData := AInfo^.UserData; 847 848 // round values 849 V := Round(AAdjustment^.Value); 850 U := Round(AAdjustment^.Upper); 851 L := Round(AAdjustment^.Lower); 852 StepI := Round(AAdjustment^.Step_Increment); 853 PageI := Round(AAdjustment^.Page_Increment); 854 855 OldValue := ScrollingData^.VValue; 856 ScrollingData^.VValue := V; 857 858 // get keystates 859 Mask := 0; 860 if ScrollingData^.VScroll <> nil 861 then begin 862 {$IFDEF UseGDKErrorTrap} 863 BeginGDKErrorTrap; 864 {$ENDIF} 865 gdk_window_get_pointer(GetControlWindow(ScrollingData^.VScroll), @X, @Y, @Mask); 866 {$IFDEF UseGDKErrorTrap} 867 EndGDKErrorTrap; 868 {$ENDIF} 869 end; 870 871 Msg.msg := LM_VSCROLL; 872 // Get scrollcode 873 if ssLeft in GTKEventStateToShiftState(Word(Mask)) 874 then Msg.ScrollCode := SB_THUMBTRACK 875 else if V <= L 876 then Msg.ScrollCode := SB_TOP 877 else if V >= U 878 then Msg.ScrollCode := SB_BOTTOM 879 else if V - OldValue = StepI 880 then Msg.ScrollCode := SB_LINEDOWN 881 else if OldValue - V = StepI 882 then Msg.ScrollCode := SB_LINEUP 883 else if V - OldValue = PageI 884 then Msg.ScrollCode := SB_PAGEDOWN 885 else if OldValue - V = PageI 886 then Msg.ScrollCode := SB_PAGEUP 887 else Msg.ScrollCode := SB_THUMBPOSITION; 888 Msg.Pos := V; 889 if V < High(Msg.SmallPos) 890 then Msg.SmallPos := V 891 else Msg.SmallPos := High(Msg.SmallPos); 892 Msg.ScrollBar := HWND(PtrUInt(ScrollingData^.HScroll)); 893 894 Result := (DeliverMessage(AInfo^.LCLObject, Msg) <> 0) xor CallBackDefaultReturn; 895end; 896 897class function TGtkWSBaseScrollingWinControl.CreateHandle( 898 const AWinControl: TWinControl; const AParams: TCreateParams): HWND; 899var 900 Widget: PGtkWidget; 901 WidgetInfo: PWidgetInfo; 902 ScrollingData: PBaseScrollingWinControlData; 903 Allocation: TGTKAllocation; 904begin 905 Widget := gtk_scrolled_window_new(nil, nil); 906 {$IFDEF DebugLCLComponents} 907 DebugGtkWidgets.MarkCreated(Widget,dbgsName(AWinControl)); 908 {$ENDIF} 909 910 Result := THandle(PtrUInt(Widget)); 911 if Result = 0 then Exit; 912 913 gtk_widget_show(Widget); 914 915 WidgetInfo := CreateWidgetInfo(Widget, AWinControl, AParams); 916 New(ScrollingData); 917 ScrollingData^.HValue := 0; 918 ScrollingData^.VValue := 0; 919 ScrollingData^.HScroll := PGtkScrolledWindow(Widget)^.HScrollbar; 920 ScrollingData^.VScroll := PGtkScrolledWindow(Widget)^.VScrollbar; 921 WidgetInfo^.UserData := ScrollingData; 922 WidgetInfo^.DataOwner := True; 923 924 // set allocation 925 Allocation.X := AParams.X; 926 Allocation.Y := AParams.Y; 927 Allocation.Width := AParams.Width; 928 Allocation.Height := AParams.Height; 929 gtk_widget_size_allocate(Widget, @Allocation); 930 Set_RC_Name(AWinControl, Widget); 931 932 // SetCallbacks isn't called here, it should be done in the 'derived' class 933end; 934 935class procedure TGtkWSBaseScrollingWinControl.SetCallbacks( 936 const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo); 937begin 938 TGtkWSWinControl.SetCallbacks(PGtkObject(AWidget), 939 TComponent(AWidgetInfo^.LCLObject)); 940 SignalConnect( 941 PGtkWidget(GetWidgetHAdjustment(AWidget)), 942 'value-changed', 943 @GtkWSBaseScrollingWinControl_HValueChanged, 944 AWidgetInfo 945 ); 946 SignalConnect( 947 PGtkWidget(GetWidgetVAdjustment(AWidget)), 948 'value-changed', 949 @GtkWSBaseScrollingWinControl_VValueChanged, 950 AWidgetInfo 951 ); 952end; 953 954{ TGtkWSDragImageListResolution } 955 956class function TGtkWSDragImageListResolution.BeginDrag( 957 const ADragImageList: TDragImageListResolution; Window: HWND; AIndex, X, Y: Integer 958 ): Boolean; 959var 960 ABitmap: TBitmap; 961 GDIObject: PGDIObject; 962 Pixmap: PGdkPixmap; 963 Mask: PGdkBitmap; 964begin 965 ABitmap := TBitmap.Create; 966 ADragImageList.GetBitmap(AIndex, ABitmap); 967 968 if (ABitmap.Handle = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then 969 begin 970 Result := False; 971 Exit; 972 end; 973 974 GDIObject := PGDIObject(ABitmap.Handle); 975 976 Pixmap := nil; 977 Mask := nil; 978 case GDIObject^.GDIBitmapType of 979 gbBitmap: 980 begin 981 Pixmap := GDIObject^.GDIBitmapObject; 982 gdk_bitmap_ref(Pixmap); 983 Mask := nil; 984 end; 985 gbPixmap: 986 begin 987 Pixmap := GDIObject^.GDIPixmapObject.Image; 988 Mask := GDIObject^.GDIPixmapObject.Mask; 989 gdk_pixmap_ref(Pixmap); 990 gdk_bitmap_ref(Mask); 991 end; 992 gbPixbuf: 993 begin 994 Pixmap := nil; 995 Mask := nil; 996 gdk_pixbuf_render_pixmap_and_mask(GDIObject^.GDIPixbufObject, Pixmap, Mask, $80); 997 end; 998 end; 999 1000 Result := GtkWidgetset.DragImageList_BeginDrag(Pixmap, Mask, ADragImageList.DragHotSpot); 1001 if Result then 1002 GtkWidgetset.DragImageList_DragMove(X, Y); 1003 gdk_pixmap_unref(Pixmap); 1004 gdk_bitmap_unref(Mask); 1005 ABitmap.Free; 1006end; 1007 1008class function TGtkWSDragImageListResolution.DragMove( 1009 const ADragImageList: TDragImageListResolution; X, Y: Integer): Boolean; 1010begin 1011 Result := GtkWidgetset.DragImageList_DragMove(X, Y); 1012end; 1013 1014class procedure TGtkWSDragImageListResolution.EndDrag( 1015 const ADragImageList: TDragImageListResolution); 1016begin 1017 GtkWidgetset.DragImageList_EndDrag; 1018end; 1019 1020class function TGtkWSDragImageListResolution.HideDragImage( 1021 const ADragImageList: TDragImageListResolution; ALockedWindow: HWND; DoUnLock: Boolean 1022 ): Boolean; 1023begin 1024 Result := GtkWidgetset.DragImageList_SetVisible(False); 1025end; 1026 1027class function TGtkWSDragImageListResolution.ShowDragImage( 1028 const ADragImageList: TDragImageListResolution; ALockedWindow: HWND; X, Y: Integer; 1029 DoLock: Boolean): Boolean; 1030begin 1031 Result := GtkWidgetset.DragImageList_DragMove(X, Y) and GtkWidgetset.DragImageList_SetVisible(True); 1032end; 1033 1034end. 1035