From 95a19394a4a584eb6e71d4047a07b16f16416d37 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sun, 22 Aug 2010 13:48:20 +0200 Subject: Introduced a new cross-platform fpgFileSize() helper function. --- src/corelib/gdi/fpg_utils_impl.inc | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_utils_impl.inc b/src/corelib/gdi/fpg_utils_impl.inc index d3bb2f0c..08a3c3ad 100644 --- a/src/corelib/gdi/fpg_utils_impl.inc +++ b/src/corelib/gdi/fpg_utils_impl.inc @@ -1,7 +1,7 @@ {%mainunit fpg_utils.pas} uses - Shellapi; + Shellapi, Windows; // GDI specific implementations of encoding functions @@ -26,3 +26,22 @@ begin end; end; +function fpgFileSize(const AFilename: TfpgString): integer; +var + FindData: TWIN32FindDataW; + FindHandle: THandle; + Str: widestring; +begin + // Don't assign the widestring to TSearchRec.name because it is of type + // string, which will generate a conversion to the system encoding + Str := UTF8Decode(Filename); + FindHandle:=Windows.FindFirstFileW(PWideChar(Str), FindData); + if FindHandle=Windows.Invalid_Handle_value then + begin + Result:=-1; + exit; + end; + Result := (int64(FindData.nFileSizeHigh) shl 32)+FindData.nFileSizeLow; + Windows.FindClose(FindHandle); +end; + -- cgit v1.2.3-70-g09d2 From d5b40c8714d023c4f8a1ecc33bbbbc146de1439b Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 23 Aug 2010 12:43:41 +0200 Subject: Fix compilation error under Windows. --- src/corelib/fpg_utils.pas | 2 +- src/corelib/gdi/fpg_utils_impl.inc | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_utils.pas b/src/corelib/fpg_utils.pas index 43f73028..107fb262 100644 --- a/src/corelib/fpg_utils.pas +++ b/src/corelib/fpg_utils.pas @@ -192,7 +192,7 @@ begin break; until fpgFindNext(FileInfo) <> 0; finally - FindClose(FileInfo); + SysUtils.FindClose(FileInfo); end; end; end; diff --git a/src/corelib/gdi/fpg_utils_impl.inc b/src/corelib/gdi/fpg_utils_impl.inc index 08a3c3ad..e5125312 100644 --- a/src/corelib/gdi/fpg_utils_impl.inc +++ b/src/corelib/gdi/fpg_utils_impl.inc @@ -34,7 +34,7 @@ var begin // Don't assign the widestring to TSearchRec.name because it is of type // string, which will generate a conversion to the system encoding - Str := UTF8Decode(Filename); + Str := UTF8Decode(AFilename); FindHandle:=Windows.FindFirstFileW(PWideChar(Str), FindData); if FindHandle=Windows.Invalid_Handle_value then begin -- cgit v1.2.3-70-g09d2 From 41336db4593f4ef94e6eec6c7a78f278f1125f87 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 26 Aug 2010 12:29:37 +0200 Subject: GDI: Correctly implement clipboard support under Windows. This includes unicode text support. --- src/corelib/fpg_base.pas | 3 ++- src/corelib/gdi/fpg_gdi.pas | 49 +++++++++++++++++++++++++++------------------ 2 files changed, 32 insertions(+), 20 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index b9bc394b..dab57e0c 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -531,7 +531,7 @@ type procedure DoSetText(const AValue: TfpgString); virtual; abstract; procedure InitClipboard; virtual; abstract; public - constructor Create; + constructor Create; virtual; property Text: TfpgString read DoGetText write DoSetText; end; @@ -2296,6 +2296,7 @@ end; constructor TfpgClipboardBase.Create; begin + inherited Create; InitClipboard; end; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index e242bfb6..ccf460e2 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -2350,36 +2350,47 @@ begin end; procedure TfpgGDIClipboard.DoSetText(const AValue: TfpgString); +var + mem: THandle; + po2: PWideChar; + str: PWideChar; begin FClipboardText := AValue; - if OpenClipboard(FClipboardWndHandle) then + if OpenClipboard(0) then begin - EmptyClipboard; - SetClipboardData(CF_TEXT, 0); + str := PWideChar(Utf8Decode(AValue)); + if EmptyClipboard then + begin + // Allocate a global memory object for the text. + mem:= globalalloc(GMEM_MOVEABLE or GMEM_DDESHARE, (length(AValue)+1)*2); + if mem <> 0 then + begin + po2:= globallock(mem); + if po2 <> nil then + begin + move(str^, po2^, (length(AValue)+1)*2); + globalunlock(mem); + if SetClipboardData(CF_UNICODETEXT,longword(mem)) <> 0 then + begin + //writeln('Successfully copied to clipboard'); + end; + end + else + begin + globalfree(mem); + end; + end; + end; CloseClipboard; end; end; procedure TfpgGDIClipboard.InitClipboard; begin - {$WARNING This does not work! 'FPGUI' window class was not registered, - so CreateWindowEx always returns 0} - FClipboardWndHandle := Windows.CreateWindowEx( - 0, // extended window style - 'FPGUI', // registered class name - nil, // window name - 0, // window style - 0, // horizontal position of window - 0, // vertical position of window - 10, // window width - 10, // window height - 0, // handle to parent or owner window - 0, // menu handle or child identifier - MainInstance, // handle to application instance - nil // window-creation data - ); + // nothing to do here end; + { TfpgGDIFileList } function TfpgGDIFileList.EncodeAttributesString(attrs: longword -- cgit v1.2.3-70-g09d2 From 2ffdd747a6f01ba994e8484523695bf7346bca63 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 30 Aug 2010 11:44:24 +0200 Subject: Fix bug returning to previous active window after opening modal form * If you had a main form and a non-modal form, and the non-modal opened a modal window, then the following happened in error: - modal form could open behind non-modal for, treating main form as parent. - when modal form closed, it set main form active, instead of non-modal form. This is now fixed. --- src/corelib/gdi/fpg_gdi.pas | 8 ++++++-- src/corelib/x11/fpg_x11.pas | 2 ++ 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index ccf460e2..26abf534 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1392,8 +1392,12 @@ begin end else if WindowType = wtModalForm then begin - // set parent window to special hidden window. It helps to hide window taskbar button. - FParentWinHandle := wapplication.GetHiddenWindow; + if FocusRootWidget <> nil then + FParentWinHandle := FocusRootWidget.WinHandle + else + // set parent window to special hidden window. It helps to hide window taskbar button. + FParentWinHandle := wapplication.GetHiddenWindow; + // for modal windows, this is necessary FWinStyle := WS_OVERLAPPEDWINDOW or WS_POPUPWINDOW; FWinStyle := FWinStyle and not (WS_MINIMIZEBOX); diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 26c61a69..2b4c0418 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -1476,6 +1476,8 @@ begin lmwh := 0; if fpgApplication.PrevModalForm <> nil then lmwh := TfpgX11Window(fpgApplication.PrevModalForm).WinHandle + else if FocusRootWidget <> nil then + lmwh := TfpgX11Window(FocusRootWidget).WinHandle else if fpgApplication.MainForm <> nil then lmwh := TfpgX11Window(fpgApplication.MainForm).WinHandle; if lmwh <> 0 then -- cgit v1.2.3-70-g09d2 From 5ee3a96c5219959d61d42c4c5f6a9c4369a79af3 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 1 Sep 2010 08:14:23 +0200 Subject: GDI: replaced debug writeln's with SendDebug() calls. We should rather use the debug server for debugging, it works much better. --- src/corelib/gdi/fpg_gdi.pas | 46 +++++++++++++++++++++------------------------ 1 file changed, 21 insertions(+), 25 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 26abf534..9851ebb7 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -32,7 +32,11 @@ uses Classes, SysUtils, fpg_base, - fpg_impl; + fpg_impl + {$IFDEF DEBUG} + ,dbugintf + {$ENDIF DEBUG} + ; { Constants missing on windows unit } const @@ -631,7 +635,7 @@ begin if not (w is TfpgGDIWindow) then begin - {$IFDEF DEBUG} writeln('fpGFX/GDI: Unable to detect Window - using DefWindowProc'); {$ENDIF} + {$IFDEF DEBUG} SendDebug('fpGFX/GDI: Unable to detect Window - using DefWindowProc'); {$ENDIF} Result := Windows.DefWindowProc(hwnd, uMsg, wParam, lParam); Exit; //==> end; @@ -646,8 +650,7 @@ begin WM_KEYDOWN, WM_SYSKEYDOWN: begin - {$IFDEF DEBUG} write(w.ClassName + ': '); {$ENDIF} - {$IFDEF DEBUG} writeln('wm_char, wm_keyup, wm_keydown'); {$ENDIF} + {$IFDEF DEBUG} SendDebug(w.ClassName + ': wm_char, wm_keyup, wm_keydown'); {$ENDIF} kwg := FindKeyboardFocus; if kwg <> nil then w := kwg; @@ -715,7 +718,7 @@ begin begin {$IFDEF DEBUG} if uMsg <> WM_MOUSEMOVE then - writeln('fpGFX/GDI: Found a mouse button event'); + SendDebug('fpGFX/GDI: Found a mouse button event'); {$ENDIF} // msgp.mouse.x := smallint(lParam and $FFFF); // msgp.mouse.y := smallint((lParam and $FFFF0000) shr 16); @@ -725,16 +728,15 @@ begin if uMsg = WM_MOUSEMOVE then begin {$IFDEF DEBUG} - Writeln('old x=', OldMousePos.x, ' y=', OldMousePos.y); - writeln('new x=', msgp.mouse.x, ' y=', msgp.mouse.y); - writeln('---'); + SendDebugFmt('old x=%d y=%d', [OldMousePos.x, OldMousePos.y]); + SendDebugFmt('new x=%d y=%d', [msgp.mouse.x, msgp.mouse.y]); {$ENDIF} // Check for fake MouseMove messages - Windows sucks! if (OldMousePos.x = msgp.mouse.x) and (OldMousePos.y = msgp.mouse.y) then begin {$IFDEF DEBUG} - writeln('We received fake MouseMove messages'); + SendDebug('We received fake MouseMove messages'); {$ENDIF} Exit; //==> end @@ -790,7 +792,7 @@ begin WM_RBUTTONDOWN: begin {$IFDEF DEBUG} - writeln('fpGUI/GDI:', w.ClassName + ': MouseButtonDown event'); + SendDebug('fpGUI/GDI: ' + w.ClassName + ': MouseButtonDown event'); {$ENDIF} // This is temporary and we should try and move it to // the UI Designer code instead. @@ -807,7 +809,7 @@ begin WM_RBUTTONUP: begin {$IFDEF DEBUG} - writeln('fpGFX/GDI:', w.ClassName + ': MouseButtonUp event'); + SendDebug('fpGFX/GDI: '+ w.ClassName + ': MouseButtonUp event'); {$ENDIF} // This is temporary and we should try and move it to // the UI Designer code instead. @@ -875,8 +877,7 @@ begin msgp.rect.Height := smallint((lParam and $FFFF0000) shr 16); {$IFDEF DEBUG} - write(w.ClassName + ': '); - writeln('WM_SIZE: width=',msgp.rect.width, ' height=',msgp.rect.height); + SendDebugFmt('%s: WM_SIZE w=%d h=%d', [w.ClassName, msgp.rect.width, msgp.rect.Height]); {$ENDIF} // skip minimize... if lparam <> 0 then @@ -886,8 +887,7 @@ begin WM_MOVE: begin {$IFDEF DEBUG} - write(w.ClassName + ': '); - writeln('WM_MOVE'); + SendDebug(w.ClassName + ': WM_MOVE'); {$ENDIF} // window decoration correction ... if (GetWindowLong(w.WinHandle, GWL_STYLE) and WS_CHILD) = 0 then @@ -908,8 +908,7 @@ begin WM_MOUSEWHEEL: begin {$IFDEF DEBUG} - write(w.ClassName + ': '); - writeln('WM_MOUSEWHEEL: wp=',IntToHex(wparam,8), ' lp=',IntToHex(lparam,8)); + SendDebugFmt('%s: WM_MOUSEWHEEL: wp=%s lp=%s', [w.ClassName, IntToHex(wparam,8), IntToHex(lparam,8)]); {$ENDIF} pt.x := GET_X_LPARAM(lParam); pt.y := GET_Y_LPARAM(lParam); @@ -941,7 +940,7 @@ begin WM_ACTIVATE: // We currently use WM_NCACTIVATE instead! begin {$IFDEF DEBUG} - writeln(w.ClassName + ': WM_ACTIVATE'); + SendDebug(w.ClassName + ': WM_ACTIVATE'); {$ENDIF} if (Lo(wParam) = WA_INACTIVE) then fpgSendMessage(nil, w, FPGM_DEACTIVATE) @@ -958,8 +957,7 @@ begin WM_NCACTIVATE: begin {$IFDEF DEBUG} - write(w.ClassName + ': WM_NCACTIVATE '); - writeln(wParam); + SendDebugFmt('%s: WM_NCACTIVATE wparam=%d', [w.ClassName, wParam]); {$ENDIF} if (wParam = 0) then fpgSendMessage(nil, w, FPGM_DEACTIVATE) @@ -969,7 +967,7 @@ begin if (PopupListFirst <> nil) and (PopupListFirst.Visible) then begin {$IFDEF DEBUG} - writeln(' Blockmsg = True (part 1) : ' + PopupListFirst.ClassName); + SendDebug(' Blockmsg = True (part 1) : ' + PopupListFirst.ClassName); {$ENDIF} // This is ugly but needed for now to get TfpgCombobox to work if (PopupListFirst.ClassName <> 'TDropDownWindow') then @@ -1002,8 +1000,7 @@ begin WM_CLOSE: begin {$IFDEF DEBUG} - write(w.ClassName + ': '); - writeln('WM_Close'); + SendDebug(w.ClassName + ': WM_Close'); {$ENDIF} fpgSendMessage(nil, w, FPGM_CLOSE, msgp); end; @@ -1011,8 +1008,7 @@ begin WM_PAINT: begin {$IFDEF DEBUG} - write(w.ClassName + ': '); - writeln('WM_PAINT'); + SendDebug(w.ClassName + ': WM_PAINT'); {$ENDIF} Windows.BeginPaint(w.WinHandle, @PaintStruct); fpgSendMessage(nil, w, FPGM_PAINT, msgp); -- cgit v1.2.3-70-g09d2 From d2a915623045a7e61dee64af59f2548b74305502 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sat, 4 Sep 2010 17:15:21 +0200 Subject: fpg_utils: Added a new function that returns a config directory for fpGUI framework itself. This will be used by the File Dialog and Font Select dialog. --- src/corelib/fpg_utils.pas | 6 ++++++ src/corelib/gdi/fpg_utils_impl.inc | 2 +- src/corelib/x11/fpg_utils_impl.inc | 2 +- 3 files changed, 8 insertions(+), 2 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_utils.pas b/src/corelib/fpg_utils.pas index 78848e40..8e866922 100644 --- a/src/corelib/fpg_utils.pas +++ b/src/corelib/fpg_utils.pas @@ -41,6 +41,7 @@ function fpgAppendPathDelim(const Path: TfpgString): TfpgString; function fpgHasSubDirs(const Dir: TfpgString; AShowHidden: Boolean): Boolean; function fpgAllFilesMask: TfpgString; function fpgConvertLineEndings(const s: TfpgString): TfpgString; +function fpgGetToolkitConfigDir: TfpgString; { This is so that when we support LTR and RTL languages, the colon will be added at the correct place. } function fpgAddColon(const AText: TfpgString): TfpgString; @@ -249,6 +250,11 @@ begin Inc(i); end; +function fpgGetToolkitConfigDir: TfpgString; +begin + Result := fpgTrimR(fpgGetAppConfigDir(False), ApplicationName, True) + FPG_CONFIG_DIR; +end; + function fpgAddColon(const AText: TfpgString): TfpgString; begin { TODO : Check language direction and add colon at appropriate end. This is very crude! } diff --git a/src/corelib/gdi/fpg_utils_impl.inc b/src/corelib/gdi/fpg_utils_impl.inc index e5125312..ab4761ae 100644 --- a/src/corelib/gdi/fpg_utils_impl.inc +++ b/src/corelib/gdi/fpg_utils_impl.inc @@ -1,7 +1,7 @@ {%mainunit fpg_utils.pas} uses - Shellapi, Windows; + Shellapi, Windows, fpg_constants, fpg_stringutils; // GDI specific implementations of encoding functions diff --git a/src/corelib/x11/fpg_utils_impl.inc b/src/corelib/x11/fpg_utils_impl.inc index 908f411a..753b0ea1 100644 --- a/src/corelib/x11/fpg_utils_impl.inc +++ b/src/corelib/x11/fpg_utils_impl.inc @@ -1,7 +1,7 @@ {%mainunit fpg_utils.pas} uses - Unix, BaseUnix; + Unix, BaseUnix, fpg_constants, fpg_stringutils; // X11 specific filesystem implementations of encoding functions -- cgit v1.2.3-70-g09d2 From 7c1b509760c2920a1d80d855bb68094001918624 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 23 Sep 2010 16:43:52 +0200 Subject: GDI: make code compilable again after X11 DND implementation. --- src/corelib/gdi/fpg_gdi.pas | 33 +++++++++++++++++++++++++++++++++ src/corelib/gdi/fpg_interface.pas | 2 ++ 2 files changed, 35 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 9851ebb7..f877c3b5 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -168,6 +168,7 @@ type //procedure MoveToScreenCenter; override; procedure DoSetWindowTitle(const ATitle: string); override; procedure DoSetMouseCursor; override; + procedure DoEnableDrops(const AValue: boolean); override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -238,6 +239,19 @@ type end; + TfpgGDIMimeDataBase = class(TfpgMimeDataBase) + end; + + + TfpgGDIDrag = class(TfpgDragBase) + protected + FSource: TfpgGDIWindow; + function GetSource: TfpgGDIWindow; virtual; + public + function Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction=daCopy): TfpgDropAction; override; + end; + + implementation uses @@ -1611,6 +1625,11 @@ begin SetCursor(hc); end; +procedure TfpgGDIWindow.DoEnableDrops(const AValue: boolean); +begin + // TODO: still needs to be implemented +end; + constructor TfpgGDIWindow.Create(AOwner: TComponent); begin inherited Create(AOwner); @@ -2451,6 +2470,20 @@ begin inherited PopulateSpecialDirs(aDirectory); end; +{ TfpgGDIDrag } + +function TfpgGDIDrag.GetSource: TfpgGDIWindow; +begin + Result := FSource; +end; + +function TfpgGDIDrag.Execute(const ADropActions: TfpgDropActions; + const ADefaultAction: TfpgDropAction): TfpgDropAction; +begin + { TODO: this still needs to be implemented } + Result := daCopy; +end; + initialization wapplication := nil; MouseFocusedWH := 0; diff --git a/src/corelib/gdi/fpg_interface.pas b/src/corelib/gdi/fpg_interface.pas index c75aaa28..ef58e46d 100644 --- a/src/corelib/gdi/fpg_interface.pas +++ b/src/corelib/gdi/fpg_interface.pas @@ -33,6 +33,8 @@ type TfpgApplicationImpl = TfpgGDIApplication; TfpgClipboardImpl = TfpgGDIClipboard; TfpgFileListImpl = TfpgGDIFileList; + TfpgMimeDataImpl = TfpgGDIMimeDataBase; + TfpgDragImpl = TfpgGDIDrag; implementation -- cgit v1.2.3-70-g09d2 From 04b2ad65aeda3ce01ea96180b6e414a095e23c30 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 1 Oct 2010 17:03:46 +0200 Subject: fixed issue ID: 3030971 from SourceForge. When the date/time changes to an earlier date while an fpGUI application is running, all timers stopped firing. Under Windows all timers are reset. TODO: Found out what happens under Linux and how we can detected a date/time change. --- src/corelib/fpg_main.pas | 9 +++++++++ src/corelib/gdi/fpg_gdi.pas | 9 +++++++++ 2 files changed, 18 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_main.pas b/src/corelib/fpg_main.pas index e9b0aaba..2fe5f200 100644 --- a/src/corelib/fpg_main.pas +++ b/src/corelib/fpg_main.pas @@ -387,6 +387,7 @@ function fpgGetNamedFontList: TStringlist; // Timers rountines procedure fpgInitTimers; procedure fpgCheckTimers; +procedure fpgResetAllTimers; function fpgClosestTimer(ctime: TDateTime; amaxtime: integer): integer; function fpgGetTickCount: DWord; @@ -512,6 +513,14 @@ begin end; end; +procedure fpgResetAllTimers; +var + i: integer; +begin + for i := 0 to fpgTimers.Count-1 do + TfpgTimer(fpgTimers[i]).Reset; +end; + function fpgClosestTimer(ctime: TDateTime; amaxtime: integer): integer; var i: integer; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index f877c3b5..a9aa34a1 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -968,6 +968,15 @@ begin Result := 0; end; + WM_TIMECHANGE: + begin + {$IFDEF DEBUG} + SendDebug(w.ClassName + ': WM_TIMECHANGE'); + {$ENDIF} + writeln('fpGUI/GDI: ' + w.ClassName + ': WM_TIMECHANGE'); + fpgResetAllTimers; + end; + WM_NCACTIVATE: begin {$IFDEF DEBUG} -- cgit v1.2.3-70-g09d2 From 4d32ba06c7dbba4d4092056b01e985c12ed2041f Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 15 Oct 2010 11:11:12 +0200 Subject: fpgApplication.OnIdle was never triggered under Windows. --- src/corelib/fpg_main.pas | 2 +- src/corelib/gdi/fpg_gdi.pas | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_main.pas b/src/corelib/fpg_main.pas index 08885567..d4f81e82 100644 --- a/src/corelib/fpg_main.pas +++ b/src/corelib/fpg_main.pas @@ -1603,7 +1603,7 @@ end; procedure TfpgApplication.RunMessageLoop; begin - WaitWindowMessage(1000); + WaitWindowMessage(2000); end; { TfpgFont } diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index a9aa34a1..8780f7f6 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1182,6 +1182,8 @@ begin if (atimeoutms >= 0) and (not DoMessagesPending) then begin + if Assigned(FOnIdle) then + OnIdle(self); if atimeoutms > 0 then timerid := Windows.SetTimer(ltimerWnd, 1, atimeoutms, nil) else -- cgit v1.2.3-70-g09d2 From 55f4f81817226a13f4d77e222e7286fbc944a7ca Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:53:56 +0200 Subject: GDI: Removed definition of MW_MOUSEWHEEL. it already exists in FPC. --- src/corelib/gdi/fpg_gdi.pas | 1 - src/corelib/x11/fpg_x11.pas | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 8780f7f6..ef5251f7 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -40,7 +40,6 @@ uses { Constants missing on windows unit } const - WM_MOUSEWHEEL = $020a; // we could remove this since FPC 2.0.4 VER_PLATFORM_WIN32_CE = 3; CLEARTYPE_QUALITY = 5; diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 837b2d34..e79e820e 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -1107,6 +1107,7 @@ begin FActionType := GetAtomFromDropAction(lDropAction); end; + { Notify widget of drag status, so it can update its look } if lAccept then begin FDropPos.X := dx; -- cgit v1.2.3-70-g09d2 From 160cb66b4bf47fc26743316b07cfbad96c3ee38d Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Wed, 27 Oct 2010 13:10:15 +0200 Subject: Renamed TfpgWindowBase.DoEnabledDrops() to DoDNDEnabled() This will hopefully reduce the confusion between the other TfpgWidget.AcceptDrops property - they had too similar names. * Applied rename changes to all other descendants too * Updated DND demo project --- examples/gui/drag_n_drop/dndexample.lpr | 2 +- src/corelib/fpg_base.pas | 2 +- src/corelib/gdi/fpg_gdi.pas | 4 ++-- src/corelib/x11/fpg_x11.pas | 6 +++--- src/gui/fpg_form.pas | 16 +++++++++------- 5 files changed, 16 insertions(+), 14 deletions(-) (limited to 'src/corelib/gdi') diff --git a/examples/gui/drag_n_drop/dndexample.lpr b/examples/gui/drag_n_drop/dndexample.lpr index 706cfd42..ace8d2ea 100644 --- a/examples/gui/drag_n_drop/dndexample.lpr +++ b/examples/gui/drag_n_drop/dndexample.lpr @@ -154,7 +154,7 @@ begin SetPosition(316, 186, 512, 429); WindowTitle := 'Drop Site Demo'; Hint := ''; - EnableDrops := True; + DNDEnabled := True; Bevel1 := TfpgPanel.Create(self); with Bevel1 do diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index c08bea71..143238cf 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -445,7 +445,7 @@ type function DoWindowToScreen(ASource: TfpgWindowBase; const AScreenPos: TPoint): TPoint; virtual; abstract; procedure DoSetWindowTitle(const ATitle: string); virtual; abstract; procedure DoSetMouseCursor; virtual; abstract; - procedure DoEnableDrops(const AValue: boolean); virtual; abstract; + procedure DoDNDEnabled(const AValue: boolean); virtual; abstract; procedure SetParent(const AValue: TfpgWindowBase); virtual; function GetParent: TfpgWindowBase; virtual; function GetCanvas: TfpgCanvasBase; virtual; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index ef5251f7..db549a2c 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -167,7 +167,7 @@ type //procedure MoveToScreenCenter; override; procedure DoSetWindowTitle(const ATitle: string); override; procedure DoSetMouseCursor; override; - procedure DoEnableDrops(const AValue: boolean); override; + procedure DoDNDEnabled(const AValue: boolean); override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -1635,7 +1635,7 @@ begin SetCursor(hc); end; -procedure TfpgGDIWindow.DoEnableDrops(const AValue: boolean); +procedure TfpgGDIWindow.DoDNDEnabled(const AValue: boolean); begin // TODO: still needs to be implemented end; diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 9338fddf..9d689f4a 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -230,7 +230,7 @@ type function DoWindowToScreen(ASource: TfpgWindowBase; const AScreenPos: TPoint): TPoint; override; procedure DoUpdateWindowPosition; override; procedure DoSetMouseCursor; override; - procedure DoEnableDrops(const AValue: boolean); override; + procedure DoDNDEnabled(const AValue: boolean); override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -2130,7 +2130,7 @@ begin if QueueEnabledDrops then begin writeln('QueueEnableDrop....'); - DoEnableDrops(True); + DoDNDEnabled(True); end; end; @@ -2364,7 +2364,7 @@ begin FMouseCursorIsDirty := False; end; -procedure TfpgX11Window.DoEnableDrops(const AValue: boolean); +procedure TfpgX11Window.DoDNDEnabled(const AValue: boolean); begin // notify XDND protocol that we can handle DND if AValue then diff --git a/src/gui/fpg_form.pas b/src/gui/fpg_form.pas index f465e09e..2eb6e899 100644 --- a/src/gui/fpg_form.pas +++ b/src/gui/fpg_form.pas @@ -51,8 +51,8 @@ type FOnHide: TNotifyEvent; FOnShow: TNotifyEvent; FOnHelp: TfpgHelpEvent; - FEnableDrops: boolean; - procedure SetEnableDrops(const AValue: boolean); + FDNDEnabled: boolean; + procedure SetDNDEnabled(const AValue: boolean); protected FModalResult: TfpgModalResult; FParentForm: TfpgBaseForm; @@ -73,6 +73,7 @@ type procedure DoOnClose(var CloseAction: TCloseAction); virtual; function DoOnHelp(AHelpType: THelpType; AHelpContext: THelpContext; const AHelpKeyword: String; const AHelpFile: String; var AHandled: Boolean): Boolean; virtual; // properties + property DNDEnabled: boolean read FDNDEnabled write SetDNDEnabled default False; property Sizeable: boolean read FSizeable write FSizeable; property ModalResult: TfpgModalResult read FModalResult write FModalResult; property FullScreen: boolean read FFullScreen write FFullScreen default False; @@ -102,13 +103,13 @@ type function ShowModal: TfpgModalResult; procedure Close; function CloseQuery: boolean; virtual; - property EnableDrops: boolean read FEnableDrops write SetEnableDrops; end; TfpgForm = class(TfpgBaseForm) published property BackgroundColor; + property DNDEnabled; property FullScreen; property Height; property Hint; @@ -188,11 +189,11 @@ end; { TfpgBaseForm } -procedure TfpgBaseForm.SetEnableDrops(const AValue: boolean); +procedure TfpgBaseForm.SetDNDEnabled(const AValue: boolean); begin - if FEnableDrops = AValue then exit; - FEnableDrops := AValue; - DoEnableDrops(AValue); + if FDNDEnabled = AValue then exit; + FDNDEnabled := AValue; + DoDNDEnabled(AValue); end; procedure TfpgBaseForm.SetWindowTitle(const ATitle: string); @@ -295,6 +296,7 @@ begin FModalResult := mrNone; FFullScreen := False; FIsContainer := True; + FDNDEnabled := False; end; destructor TfpgBaseForm.Destroy; -- cgit v1.2.3-70-g09d2 From 7a94a5002ed8af6e8e163ff375bf31fb25363088 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 12 Oct 2010 17:16:49 +0200 Subject: GDI: introduced a template TGDIDragManager class * implements the IDropTarget interface * Also initialize/uninitialize OLE at application startup/stop --- src/corelib/gdi/fpg_gdi.pas | 99 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 97 insertions(+), 2 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index db549a2c..f59c7330 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -53,6 +53,7 @@ var type // forward declaration TfpgGDIWindow = class; + TGDIDragManager = class; TfpgGDIFontResource = class(TfpgFontResourceBase) @@ -142,6 +143,9 @@ type TfpgGDIWindow = class(TfpgWindowBase) + private + FDragManager: TGDIDragManager; + function GetDragManager: TGDIDragManager; private FMouseInWindow: boolean; FNonFullscreenRect: TfpgRect; @@ -150,6 +154,7 @@ type FSkipResizeMessage: boolean; function DoMouseEnterLeaveCheck(AWindow: TfpgGDIWindow; uMsg, wParam, lParam: Cardinal): Boolean; procedure WindowSetFullscreen(aFullScreen, aUpdate: boolean); + property DragManager: TGDIDragManager read GetDragManager; protected FWinHandle: TfpgWinHandle; FModalForWin: TfpgGDIWindow; @@ -171,6 +176,7 @@ type property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; + destructor Destroy; override; procedure ActivateWindow; override; procedure CaptureMouse; override; procedure ReleaseMouse; override; @@ -251,6 +257,26 @@ type end; + { TGDIDragManager } + + TGDIDragManager = class(TInterfacedObject, IDropTarget) + private + FDropTarget: TObject; { actually a TfpgWidget } + FRegistered: boolean; + { IDropTarget } + function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; + function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; + function DragLeave: HResult;StdCall; + function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall; + public + constructor Create(ADropTarget: TObject); reintroduce; + destructor Destroy; override; + procedure RegisterDragDrop; + procedure RevokeDragDrop; + property DropTarget: TObject read FDropTarget; { actually a TfpgWidget } + end; + + implementation uses @@ -266,7 +292,7 @@ var wapplication: TfpgApplication; MouseFocusedWH: HWND; OldMousePos: TPoint; // used to detect fake MouseMove events - + NeedToUnitialize: Boolean; // some required keyboard functions {$INCLUDE fpg_keys_gdi.inc} @@ -1249,7 +1275,14 @@ end; var // this are required for Windows MouseEnter & MouseExit detection. uLastWindowHndl: TfpgWinHandle; - + +function TfpgGDIWindow.GetDragManager: TGDIDragManager; +begin + if not Assigned(FDragManager) then + FDragManager := TGDIDragManager.Create(self); + Result := FDragManager; +end; + function TfpgGDIWindow.DoMouseEnterLeaveCheck(AWindow: TfpgGDIWindow; uMsg, wParam, lParam: Cardinal): Boolean; var pt, spt: Windows.POINT; @@ -1647,6 +1680,14 @@ begin FFullscreenIsSet := false; end; +destructor TfpgGDIWindow.Destroy; +begin + if (self as TfpgWidget).AcceptDrops and Assigned(FDragManager) then + FDragManager.RevokeDragDrop; + FDragManager := nil; { frees drag manager instance } + inherited Destroy; +end; + procedure TfpgGDIWindow.ActivateWindow; begin SetForegroundWindow(FWinHandle); @@ -2494,9 +2535,59 @@ begin Result := daCopy; end; +{ TGDIDragManager } + +function TGDIDragManager.DragEnter(const dataObj: IDataObject; + grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; StdCall; +begin + +end; + +function TGDIDragManager.DragOver(grfKeyState: DWORD; pt: TPoint; + var dwEffect: DWORD): HResult; StdCall; +begin + +end; + +function TGDIDragManager.DragLeave: HResult; StdCall; +begin + +end; + +function TGDIDragManager.Drop(const dataObj: IDataObject; grfKeyState: DWORD; + pt: TPoint; var dwEffect: DWORD): HResult; StdCall; +begin + +end; + +constructor TGDIDragManager.Create(ADropTarget: TObject); +begin + inherited Create; + FDropTarget := ADropTarget; + FRegistered := False; +end; + +destructor TGDIDragManager.Destroy; +begin + if FRegistered then + RevokeDragDrop; + inherited Destroy; +end; + +procedure TGDIDragManager.RegisterDragDrop; +begin + Activex.RegisterDragDrop(TfpgWidget(FDropTarget).WinHandle, self as IDropTarget) +end; + +procedure TGDIDragManager.RevokeDragDrop; +begin + ActiveX.RevokeDragDrop(TfpgWidget(FDropTarget).WinHandle); +end; + initialization wapplication := nil; MouseFocusedWH := 0; + NeedToUnitialize := Succeeded(OleInitialize(nil)); {$IFDEF WinCE} UnicodeEnabledOS := True; @@ -2514,5 +2605,9 @@ initialization FontSmoothingType := ANTIALIASED_QUALITY; {$ENDIF} +finalization + if NeedToUnitialize then + OleUninitialize; + end. -- cgit v1.2.3-70-g09d2 From 8c7e0c3444a9746fbff7caecbc2014e114b837c6 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 12 Oct 2010 17:17:35 +0200 Subject: Ad conversion helper functions from OLE DND to fpGUI DropActions --- src/corelib/gdi/fpg_gdi.pas | 48 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 41 insertions(+), 7 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index f59c7330..7da02311 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -477,20 +477,54 @@ begin {$ENDIF} end; +{ ********** Some helper conversion functions ************* } + function WinkeystateToShiftstate(keystate: cardinal): TShiftState; begin - result:= []; - if GetKeyState(vk_menu) < 0 then begin + Result := []; + if GetKeyState(vk_menu) < 0 then Include(result, ssAlt); - end; - if GetKeyState(vk_shift) < 0 then begin + if GetKeyState(vk_shift) < 0 then Include(result, ssShift); - end; - if GetKeyState(vk_control) < 0 then begin + if GetKeyState(vk_control) < 0 then Include(result, ssCtrl); - end; end; +function TranslateToFPGDropActions(const pdwEffects: DWORD): TfpgDropActions; +begin + Result := [daIgnore]; + if (pdwEffects and DROPEFFECT_LINK) <> 0 then + Result := Result + [daLink]; + if (pdwEffects and DROPEFFECT_COPY) <> 0 then + Result := Result + [daCopy]; + if (pdwEffects and DROPEFFECT_MOVE) <> 0 then + Result := Result + [daMove]; +end; + +function TranslateToFPGDropAction(const pdwEffects: DWORD): TfpgDropAction; +begin + if (pdwEffects and DROPEFFECT_LINK) <> 0 then + Result := daLink + else if (pdwEffects and DROPEFFECT_COPY) <> 0 then + Result := daCopy + else if (pdwEffects and DROPEFFECT_MOVE) <> 0 then + Result := daMove + else + Result := daIgnore; +end; + +function TranslateToWinDragEffects(const AActions: TfpgDropActions): DWORD; +begin + Result := DROPEFFECT_NONE; + if daLink in AActions then + Result := Result or DROPEFFECT_LINK; + if daCopy in AActions then + Result := Result or DROPEFFECT_COPY; + if daMove in AActions then + Result := Result or DROPEFFECT_MOVE; +end; + + {$IFDEF wince} procedure WinCESetDibBits(BMP: HBITMAP; awidth, aheight: Integer; aimgdata: Pointer; var bi: TBitmapInfo); var -- cgit v1.2.3-70-g09d2 From 295242c96cf0c0f791fcc4aeea7555269d493503 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 12 Oct 2010 17:20:40 +0200 Subject: TfpgWindowBase introduced a new abstract method * This abstract method is called from TfpgWidget's AcceptDrops setter function * Template implementation in X11 * Actual implementation in GDI --- src/corelib/fpg_base.pas | 1 + src/corelib/fpg_widget.pas | 1 + src/corelib/gdi/fpg_gdi.pas | 29 +++++++++++++++++++++++++++-- src/corelib/x11/fpg_x11.pas | 6 ++++++ 4 files changed, 35 insertions(+), 2 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index 143238cf..ff4230e8 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -446,6 +446,7 @@ type procedure DoSetWindowTitle(const ATitle: string); virtual; abstract; procedure DoSetMouseCursor; virtual; abstract; procedure DoDNDEnabled(const AValue: boolean); virtual; abstract; + procedure DoAcceptDrops(const AValue: boolean); virtual; abstract; procedure SetParent(const AValue: TfpgWindowBase); virtual; function GetParent: TfpgWindowBase; virtual; function GetCanvas: TfpgCanvasBase; virtual; diff --git a/src/corelib/fpg_widget.pas b/src/corelib/fpg_widget.pas index 2afb667a..45a480dc 100644 --- a/src/corelib/fpg_widget.pas +++ b/src/corelib/fpg_widget.pas @@ -286,6 +286,7 @@ begin if FAcceptDrops = AValue then exit; FAcceptDrops := AValue; + DoAcceptDrops(AValue); end; function TfpgWidget.GetHint: TfpgString; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 7da02311..e7c3db3c 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -28,9 +28,10 @@ unit fpg_gdi; interface uses - Windows, Classes, SysUtils, + Windows, + ActiveX, fpg_base, fpg_impl {$IFDEF DEBUG} @@ -152,6 +153,7 @@ type FNonFullscreenStyle: longword; FFullscreenIsSet: boolean; FSkipResizeMessage: boolean; + QueueAcceptDrops: boolean; function DoMouseEnterLeaveCheck(AWindow: TfpgGDIWindow; uMsg, wParam, lParam: Cardinal): Boolean; procedure WindowSetFullscreen(aFullScreen, aUpdate: boolean); property DragManager: TGDIDragManager read GetDragManager; @@ -173,6 +175,7 @@ type procedure DoSetWindowTitle(const ATitle: string); override; procedure DoSetMouseCursor; override; procedure DoDNDEnabled(const AValue: boolean); override; + procedure DoAcceptDrops(const AValue: boolean); override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -1587,6 +1590,11 @@ begin // the forms require some adjustments before the Window appears SetWindowParameters; FSkipResizeMessage := False; + + if QueueAcceptDrops then + begin + DoAcceptDrops(True); + end; end; procedure TfpgGDIWindow.DoReleaseWindowHandle; @@ -1704,7 +1712,24 @@ end; procedure TfpgGDIWindow.DoDNDEnabled(const AValue: boolean); begin - // TODO: still needs to be implemented + { GDI has nothing to do here } +end; + +procedure TfpgGDIWindow.DoAcceptDrops(const AValue: boolean); +begin + if AValue then + begin + if HasHandle then + DragManager.RegisterDragDrop + else + QueueAcceptDrops := True; // we need to do this once we have a winhandle + end + else + begin + if HasHandle then + DragManager.RevokeDragDrop; + QueueAcceptDrops := False; + end; end; constructor TfpgGDIWindow.Create(AOwner: TComponent); diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index f56a4851..4f9c4ce8 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -231,6 +231,7 @@ type procedure DoUpdateWindowPosition; override; procedure DoSetMouseCursor; override; procedure DoDNDEnabled(const AValue: boolean); override; + procedure DoAcceptDrops(const AValue: boolean); override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -2396,6 +2397,11 @@ begin XDeleteProperty(xapplication.Display, WinHandle, xapplication.XdndAware); end; +procedure TfpgX11Window.DoAcceptDrops(const AValue: boolean); +begin + { TODO : Remove EnableDrops, then recurse from here to parent top level from, and set XDNDAware property for form. } +end; + procedure TfpgX11Window.DoSetWindowTitle(const ATitle: string); var tp: TXTextProperty; -- cgit v1.2.3-70-g09d2 From f436c95222de7300653a43875c481dd30e05e7ee Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 18 Oct 2010 17:10:13 +0200 Subject: GDI: A near complete Windows OLE Drag-n-Drop implementation --- src/corelib/gdi/fpg_oledragdrop.pas | 922 ++++++++++++++++++++++++++++++++++++ 1 file changed, 922 insertions(+) create mode 100644 src/corelib/gdi/fpg_oledragdrop.pas (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas new file mode 100644 index 00000000..29ebe7c3 --- /dev/null +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -0,0 +1,922 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This unit implements the OLE Drag-n-Drop functionality of Windows. +} +unit fpg_OLEDragDrop; + +{$mode delphi}{$H+} + +interface + +uses + Windows, Classes, ActiveX, ShellAPI, fpg_base; + +const + CFSTR_FILENAMEMAPA = 'FileNameMap'; { CF_FILENAMEMAPA } + CFSTR_FILENAMEMAP = CFSTR_FILENAMEMAPA; + CFSTR_FILEDESCRIPTORA = 'FileGroupDescriptor'; { CF_FILEGROUPDESCRIPTORA } + CFSTR_FILEDESCRIPTOR = CFSTR_FILEDESCRIPTORA; + CFSTR_FILECONTENTS = 'FileContents'; { CF_FILECONTENTS } + +type + TfpgOLEFormatEtcList = class(TList) + private + function GetFormatEtc(Index: Integer): PFormatEtc; + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + public + constructor CreateCopy(AFormatEtcList: TfpgOLEFormatEtcList); + property FormatEtc[Index: Integer]: PFormatEtc read GetFormatEtc; default; + end; + + + TfpgOLEStgMediumList = class(TList) + private + function GetStgMedium(Index: Integer): PStgMedium; + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + public + property StgMedium[Index: Integer]: PStgMedium read GetStgMedium; default; + end; + + + TfpgOLEDropSource = class(TInterfacedObject, IDropSource) + private + { IDropSource } + function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall; + function GiveFeedback(dwEffect: Longint): HResult; stdcall; + end; + + + TfpgOLEDragDropEffect = (deNone, deCopy, deMove, deLink); + TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object; + TfpgOLEDragOverEvent = procedure(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object; + TfpgOLEDragDropEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect) of object; + + + TfpgOLEDropTarget = class(TObject, IInterface, IDropTarget) + private + FDropTarget: TfpgWindowBase; + FRegistered: Boolean; + FOnDragEnter: TfpgOLEDragEnterEvent; + FOnDragOver: TfpgOLEDragOverEvent; + FOnDragLeave: TNotifyEvent; + FOnDragDrop: TfpgOLEDragDropEvent; + protected + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { IDropTarget } + function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; + function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; + function DragLeave: HResult; stdcall; + function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; + + property OnDragEnter: TfpgOLEDragEnterEvent read FOnDragEnter write FOnDragEnter; + property OnDragOver: TfpgOLEDragOverEvent read FOnDragOver write FOnDragOver; + property OnDragLeave: TNotifyEvent read FOnDragLeave write FOnDragLeave; + property OnDragDrop: TfpgOLEDragDropEvent read FOnDragDrop write FOnDragDrop; + public + constructor Create(ADropTargetWidget: TfpgWindowBase); reintroduce; { Actually a TfpgWidget } + destructor Destroy; override; + procedure RegisterDragDrop; + procedure RevokeDragDrop; + property DropTarget: TfpgWindowBase read FDropTarget; + end; + + + TfpgOLEDataObject = class(TInterfacedObject, IDataObject) + private + FFormatEtcList: TfpgOLEFormatEtcList; + FStgMediumList: TfpgOLEStgMediumList; + function LookupFormatEtc(AFormat: TFormatEtc): Integer; + protected + { IDataObject } + function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall; + function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall; + function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall; + function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall; + function SetData(const formatetc: TFormatEtc; const medium: TStgMedium; fRelease: BOOL): HResult; stdcall; + function EnumFormatEtc(dwDirection: DWORD; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall; + function DAdvise(const formatetc: TFormatEtc; advf: DWORD; const advSink: IAdviseSink; out dwConnection: DWORD): HResult; stdcall; + function DUnadvise(dwConnection: DWORD): HResult; stdcall; + function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall; + public + constructor Create; overload; + constructor Create(AFormatEtcList: TfpgOLEFormatEtcList); overload; + destructor Destroy; override; + property FormatEtcList: TfpgOLEFormatEtcList read FFormatEtcList; + property StgMediumList: TfpgOLEStgMediumList read FStgMediumList; + end; + + + TfpgOLEEnumFormatEtc = class(TInterfacedObject, IEnumFORMATETC) + private + FFormatEtcList: TfpgOLEFormatEtcList; + FIndex: Integer; + protected + { IEnumFORMATETC } + function Next(celt: ULong; out elt:FormatEtc; pceltFetched: pULong=nil): HResult; stdcall; + function Skip(celt: ULong): HResult; stdcall; + function Reset: HResult; stdcall; + function Clone(out Enum: IEnumFormatEtc): HResult; stdcall; + public + constructor Create(AFormatEtcList: TfpgOLEFormatEtcList); + destructor Destroy; override; + end; + + + TDragFilesSource = class(TObject) + private + FFileNames: TStrings; + FAliasFileNames: TStrings; + function GetAliasFileNames: TStrings; + function GetSourceFileNames: TStrings; + procedure SetAliasFileNames(const Value: TStrings); + procedure SetSourceFileNames(const Value: TStrings); + public + constructor Create; + destructor Destroy; override; + procedure Execute; + property SourceFileNames: TStrings read GetSourceFileNames write SetSourceFileNames; + property AliasFileNames: TStrings read GetAliasFileNames write SetAliasFileNames; + end; + + + TDragAcceptFilesEvent = function(Sender: TObject; FileNames: TStrings): Boolean of object; + TDragAcceptPositionEvent = function(Sender: TObject; PT: TPoint): Boolean of object; + TDropFilesEvent = procedure(Sender: TObject; PT: TPoint; FileNames: TStrings) of object; + + + TDragFilesTarget = class(TfpgOLEDropTarget) + private + FDragAcceptFiles: Boolean; + FOnDragAcceptFiles: TDragAcceptFilesEvent; + FOnDragAcceptPosition: TDragAcceptPositionEvent; + FOnDropFiles: TDropFilesEvent; + procedure GetFileNamesFromDropHandle(DropHandle: HDROP; SL: TStrings); + procedure StreamToFile(Stream: IStream; const FileName: string); + protected + function DoDragAcceptFiles(DataObj: IDataObject): Boolean; + function DoDragAcceptPosition(PT: TPoint): Boolean; + procedure DoDropFiles(DataObj: IDataObject; PT: TPoint); + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override; + procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override; + procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); override; + public + property OnDragAcceptFiles: TDragAcceptFilesEvent read FOnDragAcceptFiles write FOnDragAcceptFiles; + property OnDragAcceptPosition: TDragAcceptPositionEvent read FOnDragAcceptPosition write FOnDragAcceptPosition; + property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles; + end; + + +implementation + +uses + SysUtils, ShlObj, fpg_widget; + +var + CF_FILENAMEMAP: Cardinal; + CF_FILEDESCRIPTOR: Cardinal; + CF_FILECONTENTS: Cardinal; + +procedure DeepCopyFormatEtc(P1, P2: PFormatEtc); +begin + P2^ := P1^; + if P1^.ptd <> nil then begin + P2^.ptd := CoTaskMemAlloc(SizeOf(tagDVTARGETDEVICE)); + P2^.ptd^ := P1^.ptd^; + end; +end; + +function DupGlobalMem(hMem: HGLOBAL): HGLOBAL; +var + len: DWORD; + Source: Pointer; + Dest: HGLOBAL; +begin + len := GlobalSize(hMem); + Source := GlobalLock(hMem); + Dest := GlobalAlloc(GMEM_FIXED, len); + Move(Source^, Pointer(Dest)^, len); + GlobalUnlock(hMem); + Result := Dest; +end; + +{ TDragFilesSource } + +constructor TDragFilesSource.Create; +begin + inherited Create; + FFileNames := TStringList.Create; + FAliasFileNames := TStringList.Create; +end; + +destructor TDragFilesSource.Destroy; +begin + FreeAndNil(FFileNames); + FreeAndNil(FAliasFileNames); + inherited Destroy; +end; + +procedure TDragFilesSource.Execute; +var + DataObject: TfpgOLEDataObject; + DropSource: TfpgOLEDropSource; + dwEffect: DWORD; + dwResult: HRESULT; + I: Integer; + F: PFormatEtc; + S: string; + M: PStgMedium; +begin + DataObject := TfpgOLEDataObject.Create; + + S := ''; + for I := 0 to FFileNames.Count - 1 do begin + SetLength(S, Length(S)+Length(FFileNames[I])+1); + Move(FFileNames[I][1], S[Length(S)-Length(FFileNames[I])], Length(FFileNames[I])); + S[Length(S)] := #0; + end; + SetLength(S, Length(S)+1); + S[Length(S)] := #0; + + New(F); + F^.cfFormat := CF_HDROP; + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + DataObject.FormatEtcList.Add(F); + + New(M); + M^.tymed := TYMED_HGLOBAL; + M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, SizeOf(TDropFiles)+Length(S))); + PDropFiles(M^.hGlobal)^.pFiles := SizeOf(TDropFiles); + PDropFiles(M^.hGlobal)^.pt := Point(0,0); + PDropFiles(M^.hGlobal)^.fNC := FALSE; + PDropFiles(M^.hGlobal)^.fWide := FALSE; + Move(S[1], PChar(M^.hGlobal+SizeOf(TDropFiles))^, Length(S)); + DataObject.StgMediumList.Add(M); + + if (FAliasFileNames.Count > 0) and (FAliasFileNames.Count = FFileNames.Count) then begin + S := ''; + for I := 0 to FAliasFileNames.Count - 1 do begin + SetLength(S, Length(S)+Length(FAliasFileNames[I])+1); + Move(FAliasFileNames[I][1], S[Length(S)-Length(FAliasFileNames[I])], Length(FAliasFileNames[I])); + S[Length(S)] := #0; + end; + SetLength(S, Length(S)+1); + S[Length(S)] := #0; + + New(F); + F^.cfFormat := CF_FILENAMEMAP; + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + DataObject.FormatEtcList.Add(F); + + New(M); + M^.tymed := TYMED_HGLOBAL; + M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, Length(S))); + Move(S[1], PChar(M^.hGlobal)^, Length(S)); + DataObject.StgMediumList.Add(M); + end; + + DropSource := TfpgOLEDropSource.Create; + dwResult := ActiveX.DoDragDrop(DataObject as IDataObject, DropSource as IDropSource, DROPEFFECT_COPY, @dwEffect); + + if dwResult = DRAGDROP_S_DROP then begin + if dwEffect = DROPEFFECT_COPY then begin + end; + end; +end; + +function TDragFilesSource.GetAliasFileNames: TStrings; +begin + Result := FAliasFileNames; +end; + +function TDragFilesSource.GetSourceFileNames: TStrings; +begin + Result := FFileNames; +end; + +procedure TDragFilesSource.SetAliasFileNames(const Value: TStrings); +begin + FAliasFileNames.Assign(Value); +end; + +procedure TDragFilesSource.SetSourceFileNames(const Value: TStrings); +begin + FFileNames.Assign(Value); +end; + +{ TfpgOLEDropSource } + +function TfpgOLEDropSource.GiveFeedback(dwEffect: Integer): HResult; +begin + Result := DRAGDROP_S_USEDEFAULTCURSORS; +end; + +function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; + grfKeyState: Integer): HResult; +begin + if FEscapePressed then + Result := DRAGDROP_S_CANCEL + else if (grfKeyState and (MK_LBUTTON or MK_RBUTTON) = 0) then + Result := DRAGDROP_S_DROP + else + Result := S_OK; +end; + +{ TfpgOLEDataObject } + +constructor TfpgOLEDataObject.Create(AFormatEtcList: TfpgOLEFormatEtcList); +begin + inherited Create; + FFormatEtcList := TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList); + FStgMediumList := TfpgOLEStgMediumList.Create; +end; + +constructor TfpgOLEDataObject.Create; +begin + inherited Create; + FFormatEtcList := TfpgOLEFormatEtcList.Create; + FStgMediumList := TfpgOLEStgMediumList.Create; +end; + +function TfpgOLEDataObject.DAdvise(const formatetc: TFormatEtc; advf: DWORD; + const advSink: IAdviseSink; out dwConnection: DWORD): HResult; +begin + Result := OLE_E_ADVISENOTSUPPORTED; +end; + +destructor TfpgOLEDataObject.Destroy; +begin + FreeAndNil(FFormatEtcList); + FreeAndNil(FStgMediumList); + inherited Destroy; +end; + +function TfpgOLEDataObject.DUnadvise(dwConnection: DWORD): HResult; +begin + Result := OLE_E_ADVISENOTSUPPORTED; +end; + +function TfpgOLEDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; +begin + Result := OLE_E_ADVISENOTSUPPORTED; +end; + +function TfpgOLEDataObject.EnumFormatEtc(dwDirection: DWORD; + out enumFormatEtc: IEnumFormatEtc): HResult; +begin + if dwDirection = DATADIR_GET then begin + enumFormatEtc := TfpgOLEEnumFormatEtc.Create(FFormatEtcList) as IEnumFormatEtc; + Result := S_OK; + end + else begin + Result := E_NOTIMPL; + end; +end; + +function TfpgOLEDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; + out formatetcOut: TFormatEtc): HResult; +begin + // Apparently we have to set this field to NULL even though we don't do anything else + formatetcOut.ptd := nil; + Result := E_NOTIMPL; +end; + +function TfpgOLEDataObject.GetData(const formatetcIn: TFormatEtc; + out medium: TStgMedium): HResult; +var + Idx: Integer; +begin + Idx := LookupFormatEtc(formatetcIn); + if Idx = -1 then + Result := DV_E_FORMATETC + else begin + medium.tymed := FFormatEtcList[Idx]^.tymed; + medium.PUnkForRelease := nil; + if medium.tymed = TYMED_HGLOBAL then begin + medium.hGlobal := DupGlobalMem(FStgMediumList[Idx]^.hGlobal); + Result := S_OK; + end + else + Result := DV_E_FORMATETC; + end; +end; + +function TfpgOLEDataObject.GetDataHere(const formatetc: TFormatEtc; + out medium: TStgMedium): HResult; +begin + Result := DV_E_FORMATETC; +end; + +function TfpgOLEDataObject.LookupFormatEtc(AFormat: TFormatEtc): Integer; +var + I: Integer; +begin + Result := -1; + for I := 0 to FFormatEtcList.Count - 1 do begin + if (FFormatEtcList[I]^.cfFormat = AFormat.cfFormat) and + (FFormatEtcList[I]^.dwAspect = AFormat.dwAspect) and + (FFormatEtcList[I]^.tymed = AFormat.tymed) then begin + Result := I; + Break; + end; + end; +end; + +function TfpgOLEDataObject.QueryGetData(const formatetc: TFormatEtc): HResult; +begin + if LookupFormatEtc(formatetc) >= 0 then begin + Result := S_OK; + end + else begin + Result := DV_E_FORMATETC; + end; +end; + +function TfpgOLEDataObject.SetData(const formatetc: TFormatEtc; + const medium: TStgMedium; fRelease: BOOL): HResult; +begin + Result := E_NOTIMPL; +end; + +{ TfpgOLEEnumFormatEtc } + +function TfpgOLEEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult; +var + C: TfpgOLEEnumFormatEtc; +begin + // make a duplicate enumerator + C := TfpgOLEEnumFormatEtc.Create(FFormatEtcList); + // manually set the index state + C.FIndex := FIndex; + Enum := C as IEnumFormatEtc; + Result := S_OK; +end; + +constructor TfpgOLEEnumFormatEtc.Create(AFormatEtcList: TfpgOLEFormatEtcList); +begin + FFormatEtcList := TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList); + FIndex := 0; +end; + +destructor TfpgOLEEnumFormatEtc.Destroy; +begin + FreeAndNil(FFormatEtcList); + inherited; +end; + +function TfpgOLEEnumFormatEtc.Next(celt: ULong; out elt:FormatEtc; + pceltFetched: pULong): HResult; +var + Copied: Integer; + OutBuf: PFormatEtc; +begin + // copy the FORMATETC structures into the caller's buffer + OutBuf := PFormatEtc(@elt); + Copied := 0; + while(FIndex < FFormatEtcList.Count) and (Copied < celt) do begin + DeepCopyFormatEtc(FFormatEtcList[FIndex], OutBuf); + OutBuf := PFormatEtc(Cardinal(OutBuf) + SizeOf(TFormatEtc)); + Inc(Copied); + FIndex := FIndex + 1; + end; + + // store result + if (pceltFetched <> nil) then + pceltFetched^ := Copied; + + // did we copy all that was requested? + if (Copied = celt) then Result := S_OK + else Result := S_FALSE; +end; + +function TfpgOLEEnumFormatEtc.Reset: HResult; +begin + FIndex := 0; + Result := S_OK; +end; + +function TfpgOLEEnumFormatEtc.Skip(celt: ULong): HResult; +begin + FIndex := FIndex + celt; + if FIndex <= FFormatEtcList.Count then Result := S_OK + else Result := S_FALSE; +end; + +{ TfpgOLEFormatEtcList } + +constructor TfpgOLEFormatEtcList.CreateCopy(AFormatEtcList: TfpgOLEFormatEtcList); +var + I: Integer; + P: PFormatEtc; +begin + Create; + for I := 0 to AFormatEtcList.Count - 1 do begin + New(P); + DeepCopyFormatEtc(AFormatEtcList[I], P); + Add(P); + end; +end; + +function TfpgOLEFormatEtcList.GetFormatEtc(Index: Integer): PFormatEtc; +begin + Result := PFormatEtc(Get(Index)); +end; + +procedure TfpgOLEFormatEtcList.Notify(Ptr: Pointer; Action: TListNotification); +begin + if Action = lnDeleted then begin + if PFormatEtc(Ptr)^.ptd <> nil then begin + CoTaskMemFree(PFormatEtc(Ptr)^.ptd); + end; + Dispose(PFormatEtc(Ptr)); + end; + inherited; +end; + +{ TfpgOLEStgMediumList } + +function TfpgOLEStgMediumList.GetStgMedium(Index: Integer): PStgMedium; +begin + Result := PStgMedium(Get(Index)); +end; + +procedure TfpgOLEStgMediumList.Notify(Ptr: Pointer; Action: TListNotification); +begin + if Action = lnDeleted then begin + if PStgMedium(Ptr)^.hGlobal <> 0 then begin + GlobalFree(PStgMedium(Ptr)^.hGlobal); + end; + Dispose(Ptr); + end; + inherited; +end; + +{ TfpgOLEDropTarget } + +function TfpgOLEDropTarget.DragEnter(const dataObj: IDataObject; + grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; +var + Effect: TfpgOLEDragDropEffect; +begin + dwEffect := DROPEFFECT_NONE; + Effect := deNone; + DoDragEnter(dataObj, grfKeyState, pt, Effect); + case Effect of + deNone: dwEffect := DROPEFFECT_NONE; + deCopy: dwEffect := DROPEFFECT_COPY; + deMove: dwEffect := DROPEFFECT_MOVE; + deLink: dwEffect := DROPEFFECT_LINK; + end; + Result := S_OK; +end; + +function TfpgOLEDropTarget.DragLeave: HResult; +begin + Result := S_OK; +end; + +function TfpgOLEDropTarget.DragOver(grfKeyState: DWORD; pt: TPoint; + var dwEffect: DWORD): HResult; +var + Effect: TfpgOLEDragDropEffect; +begin + if ((MK_SHIFT and grfKeyState) = MK_SHIFT) and + ((dwEffect and DROPEFFECT_MOVE) = DROPEFFECT_MOVE) then begin + Effect := deMove; + end; + if ((MK_CONTROL and grfKeyState) = MK_CONTROL) and + ((dwEffect and DROPEFFECT_COPY) = DROPEFFECT_COPY) then begin + Effect := deCopy; + end; + if dwEffect and DROPEFFECT_COPY > 0 then Effect := deCopy + else if dwEffect and DROPEFFECT_MOVE > 0 then Effect := deMove + else if dwEffect and DROPEFFECT_LINK > 0 then Effect := deLink + else Effect := deNone; + DoDragOver(grfKeyState, pt, Effect); + case Effect of + deNone: dwEffect := DROPEFFECT_NONE; + deCopy: dwEffect := DROPEFFECT_COPY; + deMove: dwEffect := DROPEFFECT_MOVE; + deLink: dwEffect := DROPEFFECT_LINK; + end; + Result := S_OK; +end; + +function TfpgOLEDropTarget.Drop(const dataObj: IDataObject; + grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; +var + Effect: TfpgOLEDragDropEffect; +begin + if dwEffect and DROPEFFECT_COPY > 0 then Effect := deCopy + else if dwEffect and DROPEFFECT_MOVE > 0 then Effect := deMove + else if dwEffect and DROPEFFECT_LINK > 0 then Effect := deLink + else Effect := deNone; + DoDragDrop(dataObj, grfKeyState, pt, Effect); + Result := S_OK; +end; + +function TfpgOLEDropTarget._AddRef: Integer; +begin + Result := 1; +end; + +function TfpgOLEDropTarget._Release: Integer; +begin + Result := 1; +end; + +function TfpgOLEDropTarget.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +constructor TfpgOLEDropTarget.Create(ADropTargetWidget: TfpgWindowBase); +begin + inherited Create; + FDropTarget := ADropTargetWidget; + FRegistered := False; +end; + +procedure TfpgOLEDropTarget.RegisterDragDrop; +begin + ActiveX.RegisterDragDrop(TfpgWidget(FDropTarget).WinHandle, Self as IDropTarget); + FRegistered := True; +end; + +procedure TfpgOLEDropTarget.RevokeDragDrop; +begin + FRegistered := False; + ActiveX.RevokeDragDrop(TfpgWidget(FDropTarget).WinHandle); +end; + +destructor TfpgOLEDropTarget.Destroy; +begin + if FRegistered then RevokeDragDrop; + inherited; +end; + +procedure TfpgOLEDropTarget.DoDragEnter(DataObj: IDataObject; + KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect); +begin + if Assigned(FOnDragEnter) then begin + FOnDragEnter(Self, DataObj, KeyState, PT, Effect); + end; +end; + +procedure TfpgOLEDropTarget.DoDragOver(KeyState: Integer; PT: TPoint; + var Effect: TfpgOLEDragDropEffect); +begin + if Assigned(FOnDragOver) then begin + FOnDragOver(Self, KeyState, PT, Effect); + end; +end; + +procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: Integer; + PT: TPoint; Effect: TfpgOLEDragDropEffect); +begin + if Assigned(FOnDragDrop) then begin + FOnDragDrop(Self, DataObj, KeyState, PT, Effect); + end; +end; + +{ TDragFilesTarget } + +function TDragFilesTarget.DoDragAcceptFiles(DataObj: IDataObject): Boolean; +const + FormatEtcHDrop: TFormatEtc = (cfFormat:CF_HDROP;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL); + FormatEtcFileDescriptor: TFormatEtc = (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL); + FormatEtcFileContents: TFormatEtc = (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_ISTREAM); +var + StgMedium: TStgMedium; + DropHandle: HDROP; + EnumFormatEtc: IEnumFORMATETC; + FE: TFormatEtc; + FetchedCount: Longint; + FormatName: array[0..MAX_PATH] of Char; + FileGroupDescriptor: PFileGroupDescriptorA; + I, Count: Integer; + FileDescriptor: TFileDescriptorA; + FileNames: TStringList; +begin + FileNames := TStringList.Create; + try + if Assigned(FOnDragAcceptFiles) then + begin + Result := False; + FormatEtcFileDescriptor.cfFormat := CF_FILEDESCRIPTOR; + FormatEtcFileContents.cfFormat := CF_FILECONTENTS; + + if (DataObj.QueryGetData(FormatEtcHDrop) = S_OK) and + (DataObj.GetData(FormatEtcHDrop,StgMedium) = S_OK) then + begin + DropHandle := StgMedium.hGlobal; + GetFileNamesFromDropHandle(DropHandle, FileNames); + Result := FOnDragAcceptFiles(Self, FileNames); + ReleaseStgMedium(StgMedium); + end + else + if (DataObj.QueryGetData(FormatEtcFileDescriptor) = S_OK) and + (DataObj.QueryGetData(FormatEtcFileContents) = S_OK) and + (DataObj.GetData(FormatEtcFileDescriptor,StgMedium) = S_OK) then + begin + FileGroupDescriptor := GlobalLock(StgMedium.hGlobal); + if FileGroupDescriptor <> nil then + begin + Count := FileGroupDescriptor^.cItems; + I := 0; + while I < Count do + begin + FileDescriptor := FileGroupDescriptor^.fgd[I]; + FileNames.Add(FileDescriptor.cFileName); + Inc(I); + end; + GlobalUnlock(StgMedium.hGlobal); + end; + Result := FOnDragAcceptFiles(Self, FileNames); + ReleaseStgMedium(StgMedium); + end + else + begin +// DataObj.EnumFormatEtc(DATADIR_GET, EnumFormatEtc); +// EnumFormatEtc.Reset; +// while EnumFormatEtc.Next(1, FE, @FetchedCount) = S_OK do begin +// GetClipboardFormatName(FE.cfFormat,FormatName,MAX_PATH); +// ShowMessage(FormatName); +// end; + end; + end + else + begin + Result := True; + end; + finally + FileNames.Free; + end; +end; + +procedure TDragFilesTarget.DoDragEnter(DataObj: IDataObject; + KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect); +begin + FDragAcceptFiles := DoDragAcceptFiles(DataObj); + if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin + inherited; + end else begin + Effect := deNone; + end; +end; + +procedure TDragFilesTarget.DoDragOver(KeyState: Integer; PT: TPoint; + var Effect: TfpgOLEDragDropEffect); +begin + if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin + inherited; + end else begin + Effect := deNone; + end; +end; + +procedure TDragFilesTarget.DoDragDrop(DataObj: IDataObject; + KeyState: Integer; PT: TPoint; Effect: TfpgOLEDragDropEffect); +begin + DoDropFiles(DataObj, PT); + inherited; +end; + +function TDragFilesTarget.DoDragAcceptPosition(PT: TPoint): Boolean; +begin + if Assigned(FOnDragAcceptPosition) then begin + Result := FOnDragAcceptPosition(Self, PT); + end else begin + Result := True; + end; +end; + +procedure TDragFilesTarget.DoDropFiles(DataObj: IDataObject; PT: TPoint); +const + FormatEtcHDrop: TFormatEtc = (cfFormat:CF_HDROP;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL); + FormatEtcFileDescriptor: TFormatEtc = + (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_HGLOBAL); + FormatEtcFileContents: TFormatEtc = + (cfFormat:0;ptd:nil;dwAspect:DVASPECT_CONTENT;lindex:-1;tymed:TYMED_ISTREAM); +var + StgMedium, StgMediumContents: TStgMedium; + DropHandle: HDROP; + FileNames: TStringList; + FileGroupDescriptor: PFileGroupDescriptorA; + I, Count: Integer; + FileDescriptor: TFileDescriptorA; + Path: array[0..MAX_PATH] of Char; + TempFileName: string; +begin + if not Assigned(FOnDropFiles) then Exit; + FileNames := TStringList.Create; + try + FormatEtcFileDescriptor.cfFormat := CF_FILEDESCRIPTOR; + FormatEtcFileContents.cfFormat := CF_FILECONTENTS; + if (DataObj.QueryGetData(FormatEtcHDrop) = S_OK) and + (DataObj.GetData(FormatEtcHDrop,StgMedium) = S_OK) then begin + DropHandle := StgMedium.hGlobal; + GetFileNamesFromDropHandle(DropHandle, FileNames); + FOnDropFiles(Self, PT, FileNames); + ReleaseStgMedium(StgMedium); + end else + if (DataObj.QueryGetData(FormatEtcFileDescriptor) = S_OK) and + (DataObj.QueryGetData(FormatEtcFileContents) = S_OK) and + (DataObj.GetData(FormatEtcFileDescriptor,StgMedium) = S_OK) then begin + GetTempPath(MAX_PATH, Path); + GetTempFileName(Path, 'PXM', 0, Path); + FileGroupDescriptor := GlobalLock(StgMedium.hGlobal); + if FileGroupDescriptor <> nil then begin + Count := FileGroupDescriptor^.cItems; + I := 0; + while I < Count do begin + FileDescriptor := FileGroupDescriptor^.fgd[I]; + TempFileName := ChangeFileExt(Path, ExtractFileExt(FileDescriptor.cFileName)); + FormatEtcFileContents.lindex := I; + if (DataObj.GetData(FormatEtcFileContents,StgMediumContents) = S_OK) then begin + StreamToFile(IStream(StgMediumContents.pstm), TempFileName); + FileNames.Clear; + FileNames.Add(TempFileName); + FOnDropFiles(Self, PT, FileNames); + ReleaseStgMedium(StgMediumContents); + end; + Inc(I); + end; + GlobalUnlock(StgMedium.hGlobal); + end; + FOnDropFiles(Self, PT, FileNames); + ReleaseStgMedium(StgMedium); + ReleaseStgMedium(StgMediumContents); + end; + finally + FileNames.Free; + end; +end; + +procedure TDragFilesTarget.GetFileNamesFromDropHandle(DropHandle: HDROP; SL: TStrings); +var + I: Integer; + Path: array[0..MAX_PATH] of Char; +begin + for I := 0 to DragQueryFile(DropHandle, $FFFFFFFF, nil, 0) do begin + DragQueryFile(DropHandle, I, Path, MAX_PATH); + SL.Add(Path); + end; + DragFinish(DropHandle); +end; + +procedure TDragFilesTarget.StreamToFile(Stream: IStream; const FileName: string); +const + BLOCK_SIZE = 4096; +var + BytesRead: Longint; + FileStream: TFileStream; + Buffer: array[0..BLOCK_SIZE] of Byte; +begin + FileStream := TFileStream.Create(FileName, fmCreate); + try + while (Stream.Read(@Buffer[0], BLOCK_SIZE, @BytesRead) = S_OK) and (BytesRead > 0) do begin + FileStream.Write(Buffer, BytesRead); + end; + finally + FileStream.Free; + end; +end; + +initialization + CF_FILENAMEMAP := RegisterClipboardFormat(CFSTR_FILENAMEMAP); + CF_FILEDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR); + CF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS); + +finalization + +end. + -- cgit v1.2.3-70-g09d2 From c50176a7efdf0545eddaf0b9d55fca1bf357e896 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 18 Oct 2010 17:12:11 +0200 Subject: GDI: Added OLE DND into TfpgGDIWindow. AcceptDrops: is implemented and can be toggled at runtime or designtime. Windows cursor also changes to show that target windows can accept drops. --- src/corelib/gdi/fpg_gdi.pas | 35 +++++++++++++++++------------------ src/corelib/gdi/fpgui_toolkit.lpk | 9 ++++++--- src/corelib/gdi/fpgui_toolkit.pas | 4 ++-- 3 files changed, 25 insertions(+), 23 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index e7c3db3c..356c7cb1 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -37,6 +37,7 @@ uses {$IFDEF DEBUG} ,dbugintf {$ENDIF DEBUG} + ,fpg_OLEDragDrop ; { Constants missing on windows unit } @@ -145,8 +146,8 @@ type TfpgGDIWindow = class(TfpgWindowBase) private - FDragManager: TGDIDragManager; - function GetDragManager: TGDIDragManager; + FDropManager: TfpgOLEDropTarget; + function GetDropManager: TfpgOLEDropTarget; private FMouseInWindow: boolean; FNonFullscreenRect: TfpgRect; @@ -156,7 +157,7 @@ type QueueAcceptDrops: boolean; function DoMouseEnterLeaveCheck(AWindow: TfpgGDIWindow; uMsg, wParam, lParam: Cardinal): Boolean; procedure WindowSetFullscreen(aFullScreen, aUpdate: boolean); - property DragManager: TGDIDragManager read GetDragManager; + property DropManager: TfpgOLEDropTarget read GetDropManager; protected FWinHandle: TfpgWinHandle; FModalForWin: TfpgGDIWindow; @@ -260,17 +261,15 @@ type end; - { TGDIDragManager } - TGDIDragManager = class(TInterfacedObject, IDropTarget) private FDropTarget: TObject; { actually a TfpgWidget } FRegistered: boolean; { IDropTarget } - function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; - function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; - function DragLeave: HResult;StdCall; - function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall; + function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; + function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; + function DragLeave: HResult;StdCall; + function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall; public constructor Create(ADropTarget: TObject); reintroduce; destructor Destroy; override; @@ -1313,11 +1312,11 @@ var // this are required for Windows MouseEnter & MouseExit detection. uLastWindowHndl: TfpgWinHandle; -function TfpgGDIWindow.GetDragManager: TGDIDragManager; +function TfpgGDIWindow.GetDropManager: TfpgOLEDropTarget; begin - if not Assigned(FDragManager) then - FDragManager := TGDIDragManager.Create(self); - Result := FDragManager; + if not Assigned(FDropManager) then + FDropManager := TfpgOLEDropTarget.Create(self); + Result := FDropManager; end; function TfpgGDIWindow.DoMouseEnterLeaveCheck(AWindow: TfpgGDIWindow; uMsg, wParam, lParam: Cardinal): Boolean; @@ -1720,14 +1719,14 @@ begin if AValue then begin if HasHandle then - DragManager.RegisterDragDrop + DropManager.RegisterDragDrop else QueueAcceptDrops := True; // we need to do this once we have a winhandle end else begin if HasHandle then - DragManager.RevokeDragDrop; + DropManager.RevokeDragDrop; QueueAcceptDrops := False; end; end; @@ -1736,14 +1735,14 @@ constructor TfpgGDIWindow.Create(AOwner: TComponent); begin inherited Create(AOwner); FWinHandle := 0; + FDropManager := nil; FFullscreenIsSet := false; end; destructor TfpgGDIWindow.Destroy; begin - if (self as TfpgWidget).AcceptDrops and Assigned(FDragManager) then - FDragManager.RevokeDragDrop; - FDragManager := nil; { frees drag manager instance } + if (self as TfpgWidget).AcceptDrops and Assigned(FDropManager) then + FDropManager.Free; inherited Destroy; end; diff --git a/src/corelib/gdi/fpgui_toolkit.lpk b/src/corelib/gdi/fpgui_toolkit.lpk index 11731043..2f606e9f 100644 --- a/src/corelib/gdi/fpgui_toolkit.lpk +++ b/src/corelib/gdi/fpgui_toolkit.lpk @@ -5,7 +5,7 @@ - + @@ -16,7 +16,6 @@ - @@ -31,7 +30,7 @@ - + @@ -352,6 +351,10 @@ + + + + diff --git a/src/corelib/gdi/fpgui_toolkit.pas b/src/corelib/gdi/fpgui_toolkit.pas index 2e3e81b6..adc1c74d 100644 --- a/src/corelib/gdi/fpgui_toolkit.pas +++ b/src/corelib/gdi/fpgui_toolkit.pas @@ -1,4 +1,4 @@ -{ This file was automatically created by Lazarus. do not edit! +{ This file was automatically created by Lazarus. Do not edit! This source is only used to compile and install the package. } @@ -18,7 +18,7 @@ uses fpg_radiobutton, fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, fpg_gdi, fpg_impl, fpg_splitter, fpg_hint, fpg_spinedit, fpg_extgraphics, fpg_ColorMapping, fpg_ColorWheel, fpg_interface, - fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils; + fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_OLEDragDrop; implementation -- cgit v1.2.3-70-g09d2 From f2897d14008a66f50a0eaf732de1b214dabb2563 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:32:11 +0200 Subject: GDI: Changed TfpgOLEDragDropEffect type to DWORD to match OLE API --- src/corelib/gdi/fpg_oledragdrop.pas | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 29ebe7c3..e7c45736 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -61,7 +61,7 @@ type TfpgOLEDragDropEffect = (deNone, deCopy, deMove, deLink); - TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object; + TfpgOLEDragEnterEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD) of object; TfpgOLEDragOverEvent = procedure(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect) of object; TfpgOLEDragDropEvent = procedure(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect) of object; @@ -75,7 +75,7 @@ type FOnDragLeave: TNotifyEvent; FOnDragDrop: TfpgOLEDragDropEvent; protected - procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual; procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; { IInterface } @@ -87,7 +87,7 @@ type function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; function DragLeave: HResult; stdcall; function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; - + public property OnDragEnter: TfpgOLEDragEnterEvent read FOnDragEnter write FOnDragEnter; property OnDragOver: TfpgOLEDragOverEvent read FOnDragOver write FOnDragOver; property OnDragLeave: TNotifyEvent read FOnDragLeave write FOnDragLeave; @@ -176,7 +176,7 @@ type function DoDragAcceptFiles(DataObj: IDataObject): Boolean; function DoDragAcceptPosition(PT: TPoint): Boolean; procedure DoDropFiles(DataObj: IDataObject; PT: TPoint); - procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override; + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); override; procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); override; procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); override; public @@ -684,14 +684,14 @@ begin end; procedure TfpgOLEDropTarget.DoDragEnter(DataObj: IDataObject; - KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect); + KeyState: LongInt; PT: TPoint; var Effect: DWORD); begin if Assigned(FOnDragEnter) then begin FOnDragEnter(Self, DataObj, KeyState, PT, Effect); end; end; -procedure TfpgOLEDropTarget.DoDragOver(KeyState: Integer; PT: TPoint; +procedure TfpgOLEDropTarget.DoDragOver(KeyState: LongInt; PT: TPoint; var Effect: TfpgOLEDragDropEffect); begin if Assigned(FOnDragOver) then begin @@ -699,7 +699,7 @@ begin end; end; -procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: Integer; +procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: LongInt; PT: TPoint; Effect: TfpgOLEDragDropEffect); begin if Assigned(FOnDragDrop) then begin @@ -783,28 +783,25 @@ begin end; procedure TDragFilesTarget.DoDragEnter(DataObj: IDataObject; - KeyState: Integer; PT: TPoint; var Effect: TfpgOLEDragDropEffect); + KeyState: LongInt; PT: TPoint; var Effect: DWORD); begin FDragAcceptFiles := DoDragAcceptFiles(DataObj); - if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin - inherited; - end else begin - Effect := deNone; - end; + if FDragAcceptFiles and DoDragAcceptPosition(PT) then + inherited DoDragEnter(DataObj, KeyState, PT, Effect) + else + Effect := DROPEFFECT_NONE; end; -procedure TDragFilesTarget.DoDragOver(KeyState: Integer; PT: TPoint; - var Effect: TfpgOLEDragDropEffect); +procedure TDragFilesTarget.DoDragOver(KeyState: LongInt; PT: TPoint; var Effect: TfpgOLEDragDropEffect); begin - if FDragAcceptFiles and DoDragAcceptPosition(PT) then begin - inherited; - end else begin + if FDragAcceptFiles and DoDragAcceptPosition(PT) then + inherited DoDragOver(KeyState, PT, Effect) + else Effect := deNone; - end; end; procedure TDragFilesTarget.DoDragDrop(DataObj: IDataObject; - KeyState: Integer; PT: TPoint; Effect: TfpgOLEDragDropEffect); + KeyState: LongInt; PT: TPoint; Effect: TfpgOLEDragDropEffect); begin DoDropFiles(DataObj, PT); inherited; -- cgit v1.2.3-70-g09d2 From bae82a7e2d8c20e852836251ba117211241db117 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:33:58 +0200 Subject: GDI: implemented some helper functions for OLE DND clipboard types --- src/corelib/gdi/fpg_oledragdrop.pas | 75 +++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index e7c45736..f348e3f0 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -185,6 +185,8 @@ type property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles; end; +function WindowsMimeLookup(const CFFormat: string): string; +function EnumDataToStringList(DataObj: IDataObject): TStringList; implementation @@ -196,6 +198,79 @@ var CF_FILEDESCRIPTOR: Cardinal; CF_FILECONTENTS: Cardinal; + +function WindowsMimeLookup(const CFFormat: string): string; +begin + { replace know clipboard formats with mime types } + if CFFormat = 'CF_TEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_UNICODETEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_OEMTEXT' then + Result := 'text/plain' + else if CFFormat = 'CF_HDROP' then + Result := 'text/uri-list' + else if CFFormat = 'CF_RICHTEXT' then + Result := 'text/html' + else + Result := CFFormat; +end; + +function WindowsClipboardFormatToString(const CFFormat: integer): string; +begin + { replace know clipboard formats with mime types } + case CFFormat of + CF_DIF : result := 'CF_DIF'; + CF_DIB : result := 'CF_DIB'; + CF_TEXT : result := 'CF_TEXT'; + CF_SYLK : result := 'CF_SYLK'; + CF_TIFF : result := 'CF_TIFF'; + CF_RIFF : result := 'CF_RIFF'; + CF_WAVE : result := 'CF_WAVE'; + CF_HDROP : result := 'CF_HDROP'; + CF_BITMAP : result := 'CF_BITMAP'; + CF_LOCALE : result := 'CF_LOCALE'; + CF_OEMTEXT : result := 'CF_OEMTEXT'; + CF_PALETTE : result := 'CF_PALETTE'; + CF_PENDATA : result := 'CF_PENDATA'; + CF_UNICODETEXT : result := 'CF_UNICODETEXT'; + CF_ENHMETAFILE : result := 'CF_ENHMETAFILE'; + CF_METAFILEPICT : result := 'CF_METAFILEPICT'; + else + Result := Format('unknown (%d)', [CFFormat]); + end; +end; + +function EnumDataToStringList(DataObj: IDataObject): TStringList; +var + FE: FORMATETC; + EnumFormats: IEnumFORMATETC; + num: integer; + lname: string; + FormatName: array[0..MAX_PATH] of Char; + i: integer; +begin + if DataObj.EnumFormatEtc(DATADIR_GET, EnumFormats) <> S_OK then + raise Exception.Create('EnumDataToStringList: Failed to get EnumFormatEtc interface'); + + Result := TStringList.Create; + EnumFormats.Reset; + while EnumFormats.Next(1, FE, @num) = S_OK do + begin + lName := ''; + i := GetClipboardFormatName(FE.cfFormat,FormatName,MAX_PATH); + if i <> 0 then + begin + lName := FormatName; + end + else + begin + lName := WindowsClipboardFormatToString(FE.cfFormat); + end; + Result.Add(lName); + end; +end; + procedure DeepCopyFormatEtc(P1, P2: PFormatEtc); begin P2^ := P1^; -- cgit v1.2.3-70-g09d2 From c5b6a7fea8272ba12b5d7ed5444402f8a810a065 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:35:14 +0200 Subject: GDI: Fixed DragEnter implementation. We should not modify the dwEffect variable before the user gets a chance to look at it. --- src/corelib/gdi/fpg_oledragdrop.pas | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index f348e3f0..1dce7d6c 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -655,24 +655,25 @@ end; function TfpgOLEDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; -var - Effect: TfpgOLEDragDropEffect; -begin - dwEffect := DROPEFFECT_NONE; - Effect := deNone; - DoDragEnter(dataObj, grfKeyState, pt, Effect); - case Effect of - deNone: dwEffect := DROPEFFECT_NONE; - deCopy: dwEffect := DROPEFFECT_COPY; - deMove: dwEffect := DROPEFFECT_MOVE; - deLink: dwEffect := DROPEFFECT_LINK; - end; +//var +// Effect: TfpgOLEDragDropEffect; +begin + //dwEffect := DROPEFFECT_NONE; + //Effect := deNone; + DoDragEnter(dataObj, grfKeyState, pt, dwEffect); + //case Effect of + // deNone: dwEffect := DROPEFFECT_NONE; + // deCopy: dwEffect := DROPEFFECT_COPY; + // deMove: dwEffect := DROPEFFECT_MOVE; + // deLink: dwEffect := DROPEFFECT_LINK; + //end; Result := S_OK; end; function TfpgOLEDropTarget.DragLeave: HResult; begin Result := S_OK; + DoDragLeave; end; function TfpgOLEDropTarget.DragOver(grfKeyState: DWORD; pt: TPoint; -- cgit v1.2.3-70-g09d2 From 14b833869c02a78c83abeb23ddac3cde95f67df0 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:35:47 +0200 Subject: GDI: Implemented DoDragLeave for droptarget --- src/corelib/gdi/fpg_oledragdrop.pas | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 1dce7d6c..39f93570 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -77,6 +77,7 @@ type protected procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual; procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragLeave; procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; { IInterface } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; @@ -775,6 +776,12 @@ begin end; end; +procedure TfpgOLEDropTarget.DoDragLeave; +begin + if Assigned(FOnDragLeave) then + FOnDragLeave(self); +end; + procedure TfpgOLEDropTarget.DoDragDrop(DataObj: IDataObject; KeyState: LongInt; PT: TPoint; Effect: TfpgOLEDragDropEffect); begin -- cgit v1.2.3-70-g09d2 From d0c9a38672f9eeb25c57a6a0a10a72266ce9b033 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:37:07 +0200 Subject: GDI: implemented a helper function for DropAction conversion --- src/corelib/gdi/fpg_gdi.pas | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 356c7cb1..68284f42 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -526,6 +526,20 @@ begin Result := Result or DROPEFFECT_MOVE; end; +function TranslateToWinDragEffect(const AAction: TfpgDropAction): DWORD; +begin + if AAction = daIgnore then + Result := DROPEFFECT_NONE + else if daLink = AAction then + Result := DROPEFFECT_LINK + else if daCopy = AAction then + Result := DROPEFFECT_COPY + else if daMove = AAction then + Result := DROPEFFECT_MOVE + else + Result := DROPEFFECT_NONE; { fallback, but should never be reached } +end; + {$IFDEF wince} procedure WinCESetDibBits(BMP: HBITMAP; awidth, aheight: Integer; aimgdata: Pointer; var bi: TBitmapInfo); -- cgit v1.2.3-70-g09d2 From 90ba379b6ee18be060051eee83e14eb26bf1770b Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 21 Oct 2010 16:37:59 +0200 Subject: GDI: Implemented HandleDNDLeave, DNDEnter and DNDPosition event handlers --- src/corelib/gdi/fpg_gdi.pas | 92 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 92 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 68284f42..33563935 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -147,7 +147,11 @@ type TfpgGDIWindow = class(TfpgWindowBase) private FDropManager: TfpgOLEDropTarget; + FDropPos: TPoint; function GetDropManager: TfpgOLEDropTarget; + procedure HandleDNDLeave(Sender: TObject); + procedure HandleDNDEnter(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); + procedure HandleDNDPosition(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); private FMouseInWindow: boolean; FNonFullscreenRect: TfpgRect; @@ -1326,10 +1330,96 @@ var // this are required for Windows MouseEnter & MouseExit detection. uLastWindowHndl: TfpgWinHandle; +procedure TfpgGDIWindow.HandleDNDLeave(Sender: TObject); +var + wg: TfpgWidget; +begin + wg := self as TfpgWidget; + if wg.AcceptDrops then { if we get here, this should always be true anyway } + begin + if Assigned(wg.OnDragLeave) then + wg.OnDragLeave(nil); + end; +end; + +procedure TfpgGDIWindow.HandleDNDEnter(Sender: TObject; DataObj: IDataObject; + KeyState: Longint; PT: TPoint; var Effect: DWORD); +var + wg: TfpgWidget; + lMimeList: TStringList; + lMimeChoice: TfpgString; + lAccept: Boolean; + lDropAction: TfpgDropAction; + EnumIntf: IEnumFORMATETC; + msgp: TfpgMessageParams; +begin + wg := self as TfpgWidget; + if wg.AcceptDrops then + begin + lAccept := False; + + { enumerate the available formats } +// DataObj.EnumFormatEtc(DATADIR_GET, EnumIntf); +// EnumIntf.Next(); + lMimeList := EnumDataToStringList(DataObj); + + lMimeChoice := 'text/plain'; +// lMimeList := TStringList.Create; +// lMimeList.Add(lMimeChoice); +// lMimeList.Add('text/html'); + lDropAction := TranslateToFPGDropAction(Effect); + if Assigned(wg.OnDragEnter) then + wg.OnDragEnter(self, nil, lMimeList, lMimeChoice, lDropAction, lAccept); + + if not lAccept then + Effect := DROPEFFECT_NONE + else + Effect := TranslateToWinDragEffect(lDropAction); + + { Notify widget of drag status, so it can update its look } + if lAccept then + begin + FDropPos.x := PT.x; + FDropPos.y := PT.y; + fillchar(msgp, sizeof(msgp), 0); + msgp.mouse.x := PT.x; + msgp.mouse.y := PT.y; + fpgPostMessage(nil, wg, FPGM_DROPENTER, msgp); + end; + + end; +end; + +procedure TfpgGDIWindow.HandleDNDPosition(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); +var + msgp: TfpgMessageParams; + wg: TfpgWidget; +begin + wg := self as TfpgWidget; + { Notify widget of drag status, so it can update its look. We do the pos + check because OLE framework calls DragOver repeatedly even if the mouse + doesn't move, but simply because the mouse is over the widget. We don't + want that, for performance reasons. } + if FDropPos <> PT then + begin + FDropPos.x := PT.x; + FDropPos.y := PT.y; + fillchar(msgp, sizeof(msgp), 0); + msgp.mouse.x := PT.x; + msgp.mouse.y := PT.y; + fpgPostMessage(nil, wg, FPGM_DROPENTER, msgp); + end; +end; + function TfpgGDIWindow.GetDropManager: TfpgOLEDropTarget; begin if not Assigned(FDropManager) then + begin FDropManager := TfpgOLEDropTarget.Create(self); + FDropManager.OnDragLeave := @HandleDNDLeave; + FDropManager.OnDragEnter := @HandleDNDEnter; + FDropManager.OnDragOver := @HandleDNDPosition; + end; Result := FDropManager; end; @@ -1750,6 +1840,8 @@ begin inherited Create(AOwner); FWinHandle := 0; FDropManager := nil; + FDropPos.x := 0; + FDropPos.y := 0; FFullscreenIsSet := false; end; -- cgit v1.2.3-70-g09d2 From 93178a594eeac26ceb2d2b0a122f1c9124b2143b Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:24:40 +0200 Subject: interface implementation methods can be private. We only work with the interface anyway, not an actual object instance. --- src/corelib/gdi/fpg_oledragdrop.pas | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 39f93570..7bf2b997 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -74,11 +74,7 @@ type FOnDragOver: TfpgOLEDragOverEvent; FOnDragLeave: TNotifyEvent; FOnDragDrop: TfpgOLEDragDropEvent; - protected - procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual; - procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; - procedure DoDragLeave; - procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; + private { IInterface } function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; @@ -88,6 +84,11 @@ type function DragOver(grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; function DragLeave: HResult; stdcall; function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult; stdcall; + protected + procedure DoDragEnter(DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); virtual; + procedure DoDragOver(KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); virtual; + procedure DoDragLeave; + procedure DoDragDrop(DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); virtual; public property OnDragEnter: TfpgOLEDragEnterEvent read FOnDragEnter write FOnDragEnter; property OnDragOver: TfpgOLEDragOverEvent read FOnDragOver write FOnDragOver; -- cgit v1.2.3-70-g09d2 From 463bc1af0193395a5ce73fbe79f008f46e987194 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:25:30 +0200 Subject: GDI: Created a help function, GetFormatEtc, that sets up a TFormatEtc record --- src/corelib/gdi/fpg_oledragdrop.pas | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 7bf2b997..0002c695 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -189,6 +189,7 @@ type function WindowsMimeLookup(const CFFormat: string): string; function EnumDataToStringList(DataObj: IDataObject): TStringList; +function GetFormatEtc(const CFFormat: DWORD): FORMATETC; implementation @@ -273,6 +274,15 @@ begin end; end; +function GetFormatEtc(const CFFormat: DWORD): FORMATETC; +begin + Result.CfFormat := CFFormat; + Result.Ptd := nil; + Result.dwAspect := DVASPECT_CONTENT; + Result.lindex := -1; + Result.tymed := TYMED_HGLOBAL; +end; + procedure DeepCopyFormatEtc(P1, P2: PFormatEtc); begin P2^ := P1^; -- cgit v1.2.3-70-g09d2 From 2c92fb8a8b26c42b5ce215c4c7ecab5f022da304 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:26:10 +0200 Subject: Implemented a bare minimum MimeType to Win Clipboard lookup function. --- src/corelib/gdi/fpg_oledragdrop.pas | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 0002c695..56415fad 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -187,7 +187,9 @@ type property OnDropFiles: TDropFilesEvent read FOnDropFiles write FOnDropFiles; end; + function WindowsMimeLookup(const CFFormat: string): string; +function WindowsClipboardLoopup(const AMime: string): DWORD; function EnumDataToStringList(DataObj: IDataObject): TStringList; function GetFormatEtc(const CFFormat: DWORD): FORMATETC; @@ -219,6 +221,15 @@ begin Result := CFFormat; end; +function WindowsClipboardLoopup(const AMime: string): DWORD; +begin + { TODO: We need to implement this correctly } + if AMime = 'text/plain' then + Result := CF_TEXT + else + Result := CF_TEXT; // fallback result +end; + function WindowsClipboardFormatToString(const CFFormat: integer): string; begin { replace know clipboard formats with mime types } -- cgit v1.2.3-70-g09d2 From 61bef3e47c911c8e2d82984adc79010940cd7bac Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:27:02 +0200 Subject: GDI: When creating a list of clipboard formats, add mime equivalents too. --- src/corelib/gdi/fpg_oledragdrop.pas | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 56415fad..c3663689 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -261,6 +261,7 @@ var EnumFormats: IEnumFORMATETC; num: integer; lname: string; + lMimeName: string; FormatName: array[0..MAX_PATH] of Char; i: integer; begin @@ -282,6 +283,10 @@ begin lName := WindowsClipboardFormatToString(FE.cfFormat); end; Result.Add(lName); + { Lets add the mime type too if we can find one } + lMimeName := WindowsMimeLookup(lName); + if lName <> lMimeName then + Result.Add(lMimeName); end; end; -- cgit v1.2.3-70-g09d2 From 1835f3a010dfdd252f3776f6aff3d5992391fb05 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:27:32 +0200 Subject: GDI: Reference to where I got info to implement Windows OLE DND --- src/corelib/gdi/fpg_oledragdrop.pas | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index c3663689..2a3cefa9 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -13,6 +13,8 @@ Description: This unit implements the OLE Drag-n-Drop functionality of Windows. + This unit is implemented based on the articles posted on + http://www.catch22.net/tuts/dragdrop/ } unit fpg_OLEDragDrop; -- cgit v1.2.3-70-g09d2 From 89fff5ef2a0262689b871d5d2717475721f5d3b0 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:28:18 +0200 Subject: GDI: Choose a more specific base class for DropTarget reference. --- src/corelib/gdi/fpg_gdi.pas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 33563935..ce80be83 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -267,7 +267,7 @@ type TGDIDragManager = class(TInterfacedObject, IDropTarget) private - FDropTarget: TObject; { actually a TfpgWidget } + FDropTarget: TfpgWindowBase; { actually a TfpgWidget } FRegistered: boolean; { IDropTarget } function DragEnter(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD): HResult;StdCall; @@ -275,11 +275,11 @@ type function DragLeave: HResult;StdCall; function Drop(const dataObj: IDataObject; grfKeyState: DWORD; pt: TPoint; var dwEffect: DWORD):HResult;StdCall; public - constructor Create(ADropTarget: TObject); reintroduce; + constructor Create(ADropTarget: TfpgWindowBase); reintroduce; destructor Destroy; override; procedure RegisterDragDrop; procedure RevokeDragDrop; - property DropTarget: TObject read FDropTarget; { actually a TfpgWidget } + property DropTarget: TfpgWindowBase read FDropTarget; { actually a TfpgWidget } end; -- cgit v1.2.3-70-g09d2 From 0feb218751cb39e3dd23077876b23293906ec68f Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:29:14 +0200 Subject: GDI: store user selected information from DragEnter event handler --- src/corelib/gdi/fpg_gdi.pas | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index ce80be83..849b55cb 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -148,6 +148,8 @@ type private FDropManager: TfpgOLEDropTarget; FDropPos: TPoint; + FUserMimeSelection: TfpgString; + FUserAcceptDrag: Boolean; function GetDropManager: TfpgOLEDropTarget; procedure HandleDNDLeave(Sender: TObject); procedure HandleDNDEnter(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); @@ -1334,6 +1336,7 @@ procedure TfpgGDIWindow.HandleDNDLeave(Sender: TObject); var wg: TfpgWidget; begin + FUserMimeSelection := ''; wg := self as TfpgWidget; if wg.AcceptDrops then { if we get here, this should always be true anyway } begin @@ -1374,7 +1377,11 @@ begin if not lAccept then Effect := DROPEFFECT_NONE else + begin Effect := TranslateToWinDragEffect(lDropAction); + FUserMimeSelection := lMimeChoice; + FUserAcceptDrag := True; + end; { Notify widget of drag status, so it can update its look } if lAccept then @@ -1843,6 +1850,8 @@ begin FDropPos.x := 0; FDropPos.y := 0; FFullscreenIsSet := false; + FUserMimeSelection := ''; + FUserAcceptDrag := False; end; destructor TfpgGDIWindow.Destroy; @@ -2724,7 +2733,7 @@ begin end; -constructor TGDIDragManager.Create(ADropTarget: TObject); +constructor TGDIDragManager.Create(ADropTarget: TfpgWindowBase); begin inherited Create; FDropTarget := ADropTarget; -- cgit v1.2.3-70-g09d2 From 98c7280a891fcb3f515de3d1b55f504df420eefd Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 22 Oct 2010 17:29:59 +0200 Subject: GDI: Implement last remaining part to allow DropTarget to receive data. --- src/corelib/gdi/fpg_gdi.pas | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 849b55cb..6182fe37 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -24,6 +24,7 @@ unit fpg_gdi; {$mode objfpc}{$H+} {.$Define Debug} +{.$Define DND_DEBUG} interface @@ -154,6 +155,7 @@ type procedure HandleDNDLeave(Sender: TObject); procedure HandleDNDEnter(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; var Effect: DWORD); procedure HandleDNDPosition(Sender: TObject; KeyState: Longint; PT: TPoint; var Effect: TfpgOLEDragDropEffect); + procedure HandleDNDDrop(Sender: TObject; DataObj: IDataObject; KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); private FMouseInWindow: boolean; FNonFullscreenRect: TfpgRect; @@ -1418,6 +1420,42 @@ begin end; end; +procedure TfpgGDIWindow.HandleDNDDrop(Sender: TObject; DataObj: IDataObject; + KeyState: Longint; PT: TPoint; Effect: TfpgOLEDragDropEffect); +var + FE: FORMATETC; + stgmed: STGMEDIUM; + data: pchar; + wg: TfpgWidget; + CF: DWORD; +begin + if not FUserAcceptDrag then + exit; + + {$IFDEF DND_DEBUG} + Writeln('TfpgGDIWindow.HandleDNDDrop'); + {$ENDIF} + + wg := self as TfpgWidget; + { construct a FORMATETC object } + CF := WindowsClipboardLoopup(FUserMimeSelection); + FE := GetFormatEtc(CF); + + if DataObj.QueryGetData(FE) = S_OK then + begin + if DataObj.GetData(FE, stgmed) = S_OK then + begin + { Yippie! the data is there, so go get it! } + data := GlobalLock(stgmed.HGLOBAL); + if Assigned(wg.OnDragDrop) then + wg.OnDragDrop(self, nil, pt.x, pt.y, data); + GlobalUnlock(stgmed.HGLOBAL); + { release the data using the COM API } + ReleaseStgMedium(stgmed); + end; + end; +end; + function TfpgGDIWindow.GetDropManager: TfpgOLEDropTarget; begin if not Assigned(FDropManager) then @@ -1426,6 +1464,7 @@ begin FDropManager.OnDragLeave := @HandleDNDLeave; FDropManager.OnDragEnter := @HandleDNDEnter; FDropManager.OnDragOver := @HandleDNDPosition; + FDropManager.OnDragDrop := @HandleDNDDrop; end; Result := FDropManager; end; -- cgit v1.2.3-70-g09d2 From 2cd819cc6aef31153f0223a92dc9071b413d42fe Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:47:29 +0200 Subject: Added a new private Drag property to TfpgGDIApplication This allows use to easily find the TfpgDrag instance we are working with. Same was done in X11 backend. --- src/corelib/gdi/fpg_gdi.pas | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 6182fe37..980339b4 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -57,6 +57,7 @@ type // forward declaration TfpgGDIWindow = class; TGDIDragManager = class; + TfpgGDIDrag = class; TfpgGDIFontResource = class(TfpgFontResourceBase) @@ -197,6 +198,10 @@ type TfpgGDIApplication = class(TfpgApplicationBase) + private + FDrag: TfpgGDIDrag; + procedure SetDrag(const AValue: TfpgGDIDrag); + property Drag: TfpgGDIDrag read FDrag write SetDrag; protected FDisplay: HDC; WindowClass: TWndClass; @@ -1162,6 +1167,13 @@ begin Result.Sort; end; +procedure TfpgGDIApplication.SetDrag(const AValue: TfpgGDIDrag); +begin + if Assigned(FDrag) then + FDrag.Free; + FDrag := AValue; +end; + function TfpgGDIApplication.GetHiddenWindow: HWND; begin if (FHiddenWindow = 0) then -- cgit v1.2.3-70-g09d2 From 187ba5cd250f2561e0156520332f4614bfba1219 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:49:24 +0200 Subject: GDI: Implemented StringToHandle in TfpgGDIDrag class This is needed so we can store a string in a global buffer for DND. This will also reduce code duplication a bit, by simply allowing us to call this function. --- src/corelib/gdi/fpg_gdi.pas | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 980339b4..18b04da0 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -265,7 +265,10 @@ type end; + { Used mainly for sending drags - being the source of the drag } TfpgGDIDrag = class(TfpgDragBase) + private + function StringToHandle(const AString: TfpgString): HGLOBAL; protected FSource: TfpgGDIWindow; function GetSource: TfpgGDIWindow; virtual; @@ -2747,6 +2750,22 @@ end; { TfpgGDIDrag } +function TfpgGDIDrag.StringToHandle(const AString: TfpgString): HGLOBAL; +var + dest: HGLOBAL; + l: integer; + p: PChar; +begin + p := PChar(AString); + l := Length(AString)+1; + { allocate and lock a global memory buffer. Make it fixed + data so we don't have to use GlobalLock } + dest := GlobalAlloc(GMEM_FIXED, l); + { Copy the string into the buffer } + Move(p^, PChar(dest)^, l); + Result := dest; +end; + function TfpgGDIDrag.GetSource: TfpgGDIWindow; begin Result := FSource; -- cgit v1.2.3-70-g09d2 From 94a597e80e106ee15e1b924068c8caaeaa9a9fa5 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:51:56 +0200 Subject: Implemented a working TfpgGDIDrag.Execute Finally we are getting somewhere with OLE DND. --- src/corelib/gdi/fpg_gdi.pas | 105 ++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 101 insertions(+), 4 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 18b04da0..14422af3 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -273,7 +273,7 @@ type FSource: TfpgGDIWindow; function GetSource: TfpgGDIWindow; virtual; public - function Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction=daCopy): TfpgDropAction; override; + function Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction=daCopy): TfpgDropAction; override; end; @@ -2771,11 +2771,108 @@ begin Result := FSource; end; -function TfpgGDIDrag.Execute(const ADropActions: TfpgDropActions; - const ADefaultAction: TfpgDropAction): TfpgDropAction; +function TfpgGDIDrag.Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction): TfpgDropAction; +var + dwEffect: DWORD; + dwResult: HRESULT; + i: Integer; + F: PFormatEtc; + S: string; + M: PStgMedium; + itm: TfpgMimeDataItem; + lEffects: DWORD; + FDataObject: TfpgOLEDataObject; + FDropSource: TfpgOLEDropSource; + lIsTranslated: boolean; begin { TODO: this still needs to be implemented } - Result := daCopy; + if FDragging then + begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIDrag.Execute (already dragging)'); + {$ENDIF} + Result := daIgnore; + end + else + begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIDrag.Execute (new drag)'); + {$ENDIF} + FDragging := True; + wapplication.Drag := self; + lEffects := TranslateToWinDragEffects(ADropActions); + FDataObject := TfpgOLEDataObject.Create; + + for i := 0 to FMimeData.Count-1 do + begin + F := nil; + M := nil; + lIsTranslated := False; + {$Note OLE DND: We are only handling strings at the moment, this needs to be extended to other types too } + itm := FMimeData[i]; + writeln(' Processing mime-type: ', itm.Format); + + { description of data we are sending } + New(F); + F^.cfFormat := WindowsClipboardLookup(itm.format, lIsTranslated); + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + FDataObject.FormatEtcList.Add(F); + + { storage for data we are sending } + s := itm.data; + New(M); + M^.tymed := TYMED_HGLOBAL; + M^.hGlobal := StringToHandle(s); + FDataObject.StgMediumList.Add(M); + + { Original mime type was translated to a known Windows CF_ formats, add + mimetype string as-is as well } + if lIsTranslated then + begin + New(F); + F^.cfFormat := RegisterClipboardFormat(PChar(itm.format)); + F^.ptd := nil; + F^.dwAspect := DVASPECT_CONTENT; + F^.lindex := -1; + F^.tymed := TYMED_HGLOBAL; + FDataObject.FormatEtcList.Add(F); + + { storage for data we are sending } + s := itm.data; + New(M); + M^.tymed := TYMED_HGLOBAL; + M^.hGlobal := StringToHandle(s); + FDataObject.StgMediumList.Add(M); + end; + end; + + { Now let OLE take over from here } + FDropSource := TfpgOLEDropSource.Create; + dwResult := ActiveX.DoDragDrop( FDataObject as IDataObject, + FDropSource as IDropSource, + lEffects, + @dwEffect); + Result := TranslateToFPGDropAction(dwEffect); + + if dwResult = DRAGDROP_S_DROP then + begin + { which action did the user select, and act accordingly } + if dwEffect = DROPEFFECT_COPY then + begin + // nothing to do here + end; + if dwEffect = DROPEFFECT_MOVE then + begin + // Sowehow we need to remove the data from source + end; + end; + +// (FDropSource as IUnknown)._Release; +// (FDataObject as IUnknown)._Release; + end; end; { TGDIDragManager } -- cgit v1.2.3-70-g09d2 From 206f0498c7b78638535af6536c9468a8a63d6b30 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:54:28 +0200 Subject: Slight improvement to the WindowsClipboardLookup method. * Introduced a new parameter to know if we translated the mime type to a known Windows CF_ clipboard type. * Fixed the spelling mistake in the function name --- src/corelib/gdi/fpg_gdi.pas | 3 ++- src/corelib/gdi/fpg_oledragdrop.pas | 25 +++++++++++++++++++------ 2 files changed, 21 insertions(+), 7 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 14422af3..bda2be25 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1443,6 +1443,7 @@ var data: pchar; wg: TfpgWidget; CF: DWORD; + lIsTranslated: Boolean; begin if not FUserAcceptDrag then exit; @@ -1453,7 +1454,7 @@ begin wg := self as TfpgWidget; { construct a FORMATETC object } - CF := WindowsClipboardLoopup(FUserMimeSelection); + CF := WindowsClipboardLookup(FUserMimeSelection, lIsTranslated); FE := GetFormatEtc(CF); if DataObj.QueryGetData(FE) = S_OK then diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 2a3cefa9..6c7dc4e9 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -191,7 +191,7 @@ type function WindowsMimeLookup(const CFFormat: string): string; -function WindowsClipboardLoopup(const AMime: string): DWORD; +function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD; function EnumDataToStringList(DataObj: IDataObject): TStringList; function GetFormatEtc(const CFFormat: DWORD): FORMATETC; @@ -223,13 +223,26 @@ begin Result := CFFormat; end; -function WindowsClipboardLoopup(const AMime: string): DWORD; +function WindowsClipboardLookup(const AMime: string; var IsTranslated: Boolean): DWORD; begin - { TODO: We need to implement this correctly } - if AMime = 'text/plain' then - Result := CF_TEXT - else + { TODO: We need to improve this implementation } + if AMime = 'text/html' then + begin + { We don't want duplicate CF_TEXT in DataObject, so register some of our + known convenience types (from TfpgMimeData) as-is } + IsTranslated := False; + Result := RegisterClipboardFormat('text/html'); + end + else if Pos('text/', AMime) = 1 then + begin + IsTranslated := True; Result := CF_TEXT; // fallback result + end + else + begin + IsTranslated := False; + Result := RegisterClipboardFormat(PChar(AMime)); + end; end; function WindowsClipboardFormatToString(const CFFormat: integer): string; -- cgit v1.2.3-70-g09d2 From 817b52396b1625a186dfe40ec9f282d2c392b6aa Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:56:54 +0200 Subject: Bugfix in EnumDataToStringList() We can't just go adding mime types without actual data associated with each entry. So now we match the mime stringlist to exact data count in IDataObject --- src/corelib/gdi/fpg_oledragdrop.pas | 4 ---- 1 file changed, 4 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 6c7dc4e9..316c9799 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -298,10 +298,6 @@ begin lName := WindowsClipboardFormatToString(FE.cfFormat); end; Result.Add(lName); - { Lets add the mime type too if we can find one } - lMimeName := WindowsMimeLookup(lName); - if lName <> lMimeName then - Result.Add(lMimeName); end; end; -- cgit v1.2.3-70-g09d2 From 3f1a38ece21e5e7da9508c57e5fe2b23bea11817 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 11:58:52 +0200 Subject: Applied same logic in X11 to OLE DND regarding preferred mime choice Mime types should be registered from most specific (first item in mime list) to least specific (last item in mime list). The preferred mime choice will be the first item in the list. Raise an error if the mime list doesn't contain data. --- src/corelib/gdi/fpg_gdi.pas | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index bda2be25..15131adf 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1378,15 +1378,15 @@ begin begin lAccept := False; - { enumerate the available formats } -// DataObj.EnumFormatEtc(DATADIR_GET, EnumIntf); -// EnumIntf.Next(); + { enumerate the available formats and return them as a StringList } lMimeList := EnumDataToStringList(DataObj); - lMimeChoice := 'text/plain'; -// lMimeList := TStringList.Create; -// lMimeList.Add(lMimeChoice); -// lMimeList.Add('text/html'); + if lMimeList.Count > 0 then + lMimeChoice := lMimeList[0] + else + {$NOTE We need to replace this message with a resouce string } + raise Exception.Create('fpGUI/GDI: no mime types available for DND operation'); + lDropAction := TranslateToFPGDropAction(Effect); if Assigned(wg.OnDragEnter) then wg.OnDragEnter(self, nil, lMimeList, lMimeChoice, lDropAction, lAccept); -- cgit v1.2.3-70-g09d2 From 420623b7b478d1bc653ef69ad6e22da344c3b478 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 12:00:50 +0200 Subject: Added DND debugging entries and minor code formatting improvements. --- src/corelib/gdi/fpg_gdi.pas | 13 ++++++++-- src/corelib/gdi/fpg_oledragdrop.pas | 49 ++++++++++++++++++++++++++----------- 2 files changed, 46 insertions(+), 16 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 15131adf..a6a94c4d 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -277,6 +277,7 @@ type end; + { Used mainly for receiving drags - being the target of the drag } TGDIDragManager = class(TInterfacedObject, IDropTarget) private FDropTarget: TfpgWindowBase; { actually a TfpgWidget } @@ -823,7 +824,7 @@ begin begin {$IFDEF DEBUG} if uMsg <> WM_MOUSEMOVE then - SendDebug('fpGFX/GDI: Found a mouse button event'); + writeln('fpGFX/GDI: Found a mouse button event'); {$ENDIF} // msgp.mouse.x := smallint(lParam and $FFFF); // msgp.mouse.y := smallint((lParam and $FFFF0000) shr 16); @@ -1353,6 +1354,9 @@ procedure TfpgGDIWindow.HandleDNDLeave(Sender: TObject); var wg: TfpgWidget; begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIWindow.HandleDNDLeave '); + {$ENDIF} FUserMimeSelection := ''; wg := self as TfpgWidget; if wg.AcceptDrops then { if we get here, this should always be true anyway } @@ -1373,6 +1377,9 @@ var EnumIntf: IEnumFORMATETC; msgp: TfpgMessageParams; begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIWindow.HandleDNDEnter '); + {$ENDIF} wg := self as TfpgWidget; if wg.AcceptDrops then begin @@ -1410,7 +1417,6 @@ begin msgp.mouse.y := PT.y; fpgPostMessage(nil, wg, FPGM_DROPENTER, msgp); end; - end; end; @@ -1426,6 +1432,9 @@ begin want that, for performance reasons. } if FDropPos <> PT then begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIWindow.HandleDNDPosition '); + {$ENDIF} FDropPos.x := PT.x; FDropPos.y := PT.y; fillchar(msgp, sizeof(msgp), 0); diff --git a/src/corelib/gdi/fpg_oledragdrop.pas b/src/corelib/gdi/fpg_oledragdrop.pas index 316c9799..fa17ba67 100644 --- a/src/corelib/gdi/fpg_oledragdrop.pas +++ b/src/corelib/gdi/fpg_oledragdrop.pas @@ -362,8 +362,10 @@ var begin DataObject := TfpgOLEDataObject.Create; + { append filenames as one long string delimited by #0. ie: something like a PChar } S := ''; - for I := 0 to FFileNames.Count - 1 do begin + for I := 0 to FFileNames.Count - 1 do + begin SetLength(S, Length(S)+Length(FFileNames[I])+1); Move(FFileNames[I][1], S[Length(S)-Length(FFileNames[I])], Length(FFileNames[I])); S[Length(S)] := #0; @@ -371,6 +373,7 @@ begin SetLength(S, Length(S)+1); S[Length(S)] := #0; + { description of data we are sending } New(F); F^.cfFormat := CF_HDROP; F^.ptd := nil; @@ -379,6 +382,7 @@ begin F^.tymed := TYMED_HGLOBAL; DataObject.FormatEtcList.Add(F); + { storage for data we are sending } New(M); M^.tymed := TYMED_HGLOBAL; M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, SizeOf(TDropFiles)+Length(S))); @@ -389,9 +393,12 @@ begin Move(S[1], PChar(M^.hGlobal+SizeOf(TDropFiles))^, Length(S)); DataObject.StgMediumList.Add(M); - if (FAliasFileNames.Count > 0) and (FAliasFileNames.Count = FFileNames.Count) then begin + if (FAliasFileNames.Count > 0) and (FAliasFileNames.Count = FFileNames.Count) then + begin + { append filename aliases as one long string delimited by #0. ie: something like a PChar } S := ''; - for I := 0 to FAliasFileNames.Count - 1 do begin + for I := 0 to FAliasFileNames.Count - 1 do + begin SetLength(S, Length(S)+Length(FAliasFileNames[I])+1); Move(FAliasFileNames[I][1], S[Length(S)-Length(FAliasFileNames[I])], Length(FAliasFileNames[I])); S[Length(S)] := #0; @@ -399,6 +406,7 @@ begin SetLength(S, Length(S)+1); S[Length(S)] := #0; + { description of data we are sending } New(F); F^.cfFormat := CF_FILENAMEMAP; F^.ptd := nil; @@ -407,6 +415,7 @@ begin F^.tymed := TYMED_HGLOBAL; DataObject.FormatEtcList.Add(F); + { storage for data we are sending } New(M); M^.tymed := TYMED_HGLOBAL; M^.hGlobal := Cardinal(GlobalAlloc(GMEM_FIXED, Length(S))); @@ -417,8 +426,11 @@ begin DropSource := TfpgOLEDropSource.Create; dwResult := ActiveX.DoDragDrop(DataObject as IDataObject, DropSource as IDropSource, DROPEFFECT_COPY, @dwEffect); - if dwResult = DRAGDROP_S_DROP then begin - if dwEffect = DROPEFFECT_COPY then begin + if dwResult = DRAGDROP_S_DROP then + begin + if dwEffect = DROPEFFECT_COPY then + begin + // nothing to do. If this whas xxx_MOVE, we would remove data from source end; end; end; @@ -450,8 +462,7 @@ begin Result := DRAGDROP_S_USEDEFAULTCURSORS; end; -function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; - grfKeyState: Integer): HResult; +function TfpgOLEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Integer): HResult; begin if FEscapePressed then Result := DRAGDROP_S_CANCEL @@ -459,6 +470,9 @@ begin Result := DRAGDROP_S_DROP else Result := S_OK; + {$IFDEF DND_DEBUG} + writeln('TfpgOLEDropSource.QueryContinueDrag Result = ', Result); + {$ENDIF} end; { TfpgOLEDataObject } @@ -503,7 +517,8 @@ end; function TfpgOLEDataObject.EnumFormatEtc(dwDirection: DWORD; out enumFormatEtc: IEnumFormatEtc): HResult; begin - if dwDirection = DATADIR_GET then begin + if dwDirection = DATADIR_GET then + begin enumFormatEtc := TfpgOLEEnumFormatEtc.Create(FFormatEtcList) as IEnumFormatEtc; Result := S_OK; end @@ -528,10 +543,12 @@ begin Idx := LookupFormatEtc(formatetcIn); if Idx = -1 then Result := DV_E_FORMATETC - else begin + else + begin medium.tymed := FFormatEtcList[Idx]^.tymed; medium.PUnkForRelease := nil; - if medium.tymed = TYMED_HGLOBAL then begin + if medium.tymed = TYMED_HGLOBAL then + begin medium.hGlobal := DupGlobalMem(FStgMediumList[Idx]^.hGlobal); Result := S_OK; end @@ -747,10 +764,14 @@ function TfpgOLEDropTarget.Drop(const dataObj: IDataObject; var Effect: TfpgOLEDragDropEffect; begin - if dwEffect and DROPEFFECT_COPY > 0 then Effect := deCopy - else if dwEffect and DROPEFFECT_MOVE > 0 then Effect := deMove - else if dwEffect and DROPEFFECT_LINK > 0 then Effect := deLink - else Effect := deNone; + if dwEffect and DROPEFFECT_COPY > 0 then + Effect := deCopy + else if dwEffect and DROPEFFECT_MOVE > 0 then + Effect := deMove + else if dwEffect and DROPEFFECT_LINK > 0 then + Effect := deLink + else + Effect := deNone; DoDragDrop(dataObj, grfKeyState, pt, Effect); Result := S_OK; end; -- cgit v1.2.3-70-g09d2 From d3bc090ffb6c1a96e2a6cb01f474f9318c4c84f1 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 12:38:03 +0200 Subject: Moved OnDragStartDetected from TfpgWidget to TfpgWindowBase * also introduced virtual DoDragStartDetected which executes the OnDragStartDetected event * We also added a override of DoDragStartDetected in GDI for some extra tasks. --- src/corelib/fpg_base.pas | 11 +++++++++++ src/corelib/fpg_widget.pas | 8 ++------ src/corelib/gdi/fpg_gdi.pas | 10 ++++++++++ 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index c81d9cd8..a5289474 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -435,6 +435,8 @@ type FSizeIsDirty: Boolean; FPosIsDirty: Boolean; FMouseCursorIsDirty: Boolean; + FOnDragStartDetected: TNotifyEvent; + FDragActive: boolean; function HandleIsValid: boolean; virtual; abstract; procedure DoUpdateWindowPosition; virtual; abstract; procedure DoAllocateWindowHandle(AParent: TfpgWindowBase); virtual; abstract; @@ -447,6 +449,7 @@ type procedure DoSetMouseCursor; virtual; abstract; procedure DoDNDEnabled(const AValue: boolean); virtual; abstract; procedure DoAcceptDrops(const AValue: boolean); virtual; abstract; + procedure DoDragStartDetected; virtual; procedure SetParent(const AValue: TfpgWindowBase); virtual; function GetParent: TfpgWindowBase; virtual; function GetCanvas: TfpgCanvasBase; virtual; @@ -459,6 +462,7 @@ type procedure SetWidth(const AValue: TfpgCoord); procedure HandleMove(x, y: TfpgCoord); virtual; procedure HandleResize(AWidth, AHeight: TfpgCoord); virtual; + property OnDragStartDetected: TNotifyEvent read FOnDragStartDetected write FOnDragStartDetected; public // The standard constructor. constructor Create(AOwner: TComponent); override; @@ -1137,6 +1141,12 @@ begin Result := MinHeight; end; +procedure TfpgWindowBase.DoDragStartDetected; +begin + if Assigned(FOnDragStartDetected) then + FOnDragStartDetected(self); +end; + procedure TfpgWindowBase.SetParent(const AValue: TfpgWindowBase); begin FParent := AValue; @@ -1257,6 +1267,7 @@ begin FSizeIsDirty := True; FMaxWidth := 0; FMaxHeight := 0; + FDragActive := False; end; procedure TfpgWindowBase.AfterConstruction; diff --git a/src/corelib/fpg_widget.pas b/src/corelib/fpg_widget.pas index 45a480dc..374a76ed 100644 --- a/src/corelib/fpg_widget.pas +++ b/src/corelib/fpg_widget.pas @@ -47,7 +47,6 @@ type FOnDragDrop: TfpgDragDropEvent; FOnDragEnter: TfpgDragEnterEvent; FOnDragLeave: TNotifyEvent; - FOnDragStartDetected: TNotifyEvent; FOnEnter: TNotifyEvent; FOnExit: TNotifyEvent; FOnMouseDown: TMouseButtonEvent; @@ -61,7 +60,6 @@ type FOnScreen: boolean; FOnShowHint: THintEvent; FDragStartPos: TfpgPoint; - FDragActive: boolean; alist: TList; procedure SetActiveWidget(const AValue: TfpgWidget); function IsShowHintStored: boolean; @@ -142,7 +140,6 @@ type { property events } property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnDoubleClick: TMouseButtonEvent read FOnDoubleClick write FOnDoubleClick; - property OnDragStartDetected: TNotifyEvent read FOnDragStartDetected write FOnDragStartDetected; property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; property OnExit: TNotifyEvent read FOnExit write FOnExit; property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; @@ -471,7 +468,6 @@ begin FBackgroundColor := clWindowBackground; FTextColor := clText1; FAcceptDrops := False; - FDragActive := False; FOnClickPending := False; inherited Create(AOwner); @@ -728,8 +724,8 @@ begin if not FDragActive and (FDragStartPos.ManhattanLength(fpgPoint(msg.Params.mouse.x, msg.Params.mouse.y)) > fpgApplication.StartDragDistance) then begin FDragActive := True; - if Assigned(OnDragStartDetected) then - OnDragStartDetected(self); + // In Windows dragging is a blocking function, so FDragActive is false after this call + DoDragStartDetected; end; end; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index a6a94c4d..c1560042 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -186,6 +186,7 @@ type procedure DoSetMouseCursor; override; procedure DoDNDEnabled(const AValue: boolean); override; procedure DoAcceptDrops(const AValue: boolean); override; + procedure DoDragStartDetected; override; property WinHandle: TfpgWinHandle read FWinHandle; public constructor Create(AOwner: TComponent); override; @@ -1906,6 +1907,15 @@ begin end; end; +procedure TfpgGDIWindow.DoDragStartDetected; +begin + inherited DoDragStartDetected; + { In windows OLE dragging is a blocking function, so it never returns until + OnStartDragDetected is complete. So we need to set FDragActive to False + here. } + FDragActive := False; +end; + constructor TfpgGDIWindow.Create(AOwner: TComponent); begin inherited Create(AOwner); -- cgit v1.2.3-70-g09d2 From 1bfb9a35d6d597a9691777dfc6b757a4366b88e3 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 12:39:38 +0200 Subject: More DND debugging code for TfpgGDIDrag class. --- src/corelib/gdi/fpg_gdi.pas | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index c1560042..e4cea8a5 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -274,6 +274,7 @@ type FSource: TfpgGDIWindow; function GetSource: TfpgGDIWindow; virtual; public + destructor Destroy; override; function Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction=daCopy): TfpgDropAction; override; end; @@ -2791,6 +2792,14 @@ begin Result := FSource; end; +destructor TfpgGDIDrag.Destroy; +begin + {$IFDEF DND_DEBUG} + writeln('TfpgGDIDrag.Destroy '); + {$ENDIF} + inherited Destroy; +end; + function TfpgGDIDrag.Execute(const ADropActions: TfpgDropActions; const ADefaultAction: TfpgDropAction): TfpgDropAction; var dwEffect: DWORD; -- cgit v1.2.3-70-g09d2 From 1be6b8dc3417de2b7b8c9c32e92755ece9d6498c Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 15:03:11 +0200 Subject: Fixed Windows DND memory leaks. --- src/corelib/gdi/fpg_gdi.pas | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) (limited to 'src/corelib/gdi') diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index e4cea8a5..e85d81e3 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1257,6 +1257,8 @@ end; destructor TfpgGDIApplication.Destroy; begin + if Assigned(FDrag) then + FDrag.Free; UnhookWindowsHookEx(ActivationHook); inherited Destroy; end; @@ -1389,17 +1391,19 @@ begin { enumerate the available formats and return them as a StringList } lMimeList := EnumDataToStringList(DataObj); - - if lMimeList.Count > 0 then - lMimeChoice := lMimeList[0] - else - {$NOTE We need to replace this message with a resouce string } - raise Exception.Create('fpGUI/GDI: no mime types available for DND operation'); - - lDropAction := TranslateToFPGDropAction(Effect); - if Assigned(wg.OnDragEnter) then - wg.OnDragEnter(self, nil, lMimeList, lMimeChoice, lDropAction, lAccept); - + try + if lMimeList.Count > 0 then + lMimeChoice := lMimeList[0] + else + {$NOTE We need to replace this message with a resouce string } + raise Exception.Create('fpGUI/GDI: no mime types available for DND operation'); + + lDropAction := TranslateToFPGDropAction(Effect); + if Assigned(wg.OnDragEnter) then + wg.OnDragEnter(self, nil, lMimeList, lMimeChoice, lDropAction, lAccept); + finally + lMimeList.Free; + end; if not lAccept then Effect := DROPEFFECT_NONE else @@ -1915,6 +1919,8 @@ begin OnStartDragDetected is complete. So we need to set FDragActive to False here. } FDragActive := False; + if Assigned(wapplication.FDrag) then + FreeAndNil(wapplication.FDrag); end; constructor TfpgGDIWindow.Create(AOwner: TComponent); @@ -1931,7 +1937,7 @@ end; destructor TfpgGDIWindow.Destroy; begin - if (self as TfpgWidget).AcceptDrops and Assigned(FDropManager) then + if Assigned(FDropManager) then FDropManager.Free; inherited Destroy; end; -- cgit v1.2.3-70-g09d2 From 27ce669bdf288e356e2ee2f9b73fd3b4ce6bfea0 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 29 Oct 2010 15:09:30 +0200 Subject: Code cleanup by removing leftover writeln() statements. --- examples/gui/drag_n_drop/dndexample.lpr | 13 +++++-------- src/corelib/gdi/fpg_gdi.pas | 2 ++ 2 files changed, 7 insertions(+), 8 deletions(-) (limited to 'src/corelib/gdi') diff --git a/examples/gui/drag_n_drop/dndexample.lpr b/examples/gui/drag_n_drop/dndexample.lpr index 13750e86..e134fb74 100644 --- a/examples/gui/drag_n_drop/dndexample.lpr +++ b/examples/gui/drag_n_drop/dndexample.lpr @@ -130,26 +130,23 @@ var d: TfpgDrag; v: variant; begin - writeln('in >'); m := TfpgMimeData.Create; + { via convenience properties } m.Text := 'My name is Earl'; m.HTML := 'My name is Earl'; - { via generic SetData function } - //m.SetData('text/special', 'type number three'); - //v := 'type number four'; - //m.SetData('text/four', v); - //m.SetData('text/five', 'type number five'); + { Could also have used the generic SetData function } +// m.SetData('text/plain', 'My name is Earl'); +// m.SetData('text/html', 'My name is Earl'); { tell TfpgDrag who is the Source of the drag } -// d := TfpgDrag.Create(MyDragSourceLabel); d := TfpgDrag.Create(Sender as TfpgWindow); { TfpgDrag now takes ownership of TfpgMimeData } d.MimeData := m; + { TfpgDrag instance will be freed later when DND action is completed } d.Execute([daCopy]); - writeln('< out'); end; procedure TMainForm.ShowMimeList(AMimeList: TStringList); diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index e85d81e3..6f95d8a8 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -2845,7 +2845,9 @@ begin lIsTranslated := False; {$Note OLE DND: We are only handling strings at the moment, this needs to be extended to other types too } itm := FMimeData[i]; + {$IFDEF DND_DEBUG} writeln(' Processing mime-type: ', itm.Format); + {$ENDIF} { description of data we are sending } New(F); -- cgit v1.2.3-70-g09d2