diff --git a/Interop.SHDocVw.dll b/Interop.SHDocVw.dll deleted file mode 100755 index a10ff26..0000000 Binary files a/Interop.SHDocVw.dll and /dev/null differ diff --git a/Interop.Shell32.dll b/Interop.Shell32.dll deleted file mode 100755 index d377ec6..0000000 Binary files a/Interop.Shell32.dll and /dev/null differ diff --git a/README.md b/README.md index 38eba12..cedb36b 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,10 @@ with an app, turn it off for that app from the tab's right-click menu. **Optional, off by default:** switch on hover, a leader key to pick tabs by letter (Alt + S, then the key on the tab), automatic tab colors, and an Alt+Tab replacement. +Drag files onto a tab and pause to bring that window forward. On a **File Explorer** +tab, let go to drop them into its folder as Explorer would: Ctrl copies, Shift moves, +right-drag asks, and **Ctrl + Z** in Explorer undoes it. + ## Features - **Appearance:** light, dark or follow Windows; Joined, Folder or Floating tabs; @@ -72,6 +76,8 @@ To update, exit WindowTabs from the tray and replace the exe. Settings are kept. (your old settings are backed up first). - **Run as administrator?** Not needed and not recommended. Windows blocks some input between admin and normal windows. +- **Dropping files on a tab does nothing?** Windows blocks dragging from an app into + one running as administrator. Still stuck? [Open an issue](https://github.com/leafOfTree/WindowTabs/issues) and paste the troubleshooting report from **Settings → Support**. It leaves out window titles diff --git a/Win32/Ole2.cs b/Win32/Ole2.cs index 5e6c660..c581073 100755 --- a/Win32/Ole2.cs +++ b/Win32/Ole2.cs @@ -171,6 +171,21 @@ public sealed class Ole2Api } public static class OleHelper { + public static List FilesInDrop(IntPtr hdrop) + { + uint count = ShellApi.DragQueryFile(hdrop, -1, IntPtr.Zero, 0); + var files = new List(); + for (int i = 0; i < count; i++) + { + // Sized to each path, so long paths are not cut short. + var size = (int)ShellApi.DragQueryFile(hdrop, i, IntPtr.Zero, 0) + 1; + var sb = new StringBuilder(size); + ShellApi.DragQueryFile(hdrop, i, sb, size); + files.Add(sb.ToString()); + } + return files; + } + public static IEnumerable QueryFiles(IDataObject dataObject) { STGMEDIUM td = new STGMEDIUM(); @@ -182,17 +197,18 @@ public static IEnumerable QueryFiles(IDataObject dataObject) fr.lindex = -1; fr.tymed = TYMED.TYMED_HGLOBAL; dataObject.GetData(ref fr, out td); - var hdrop = td.unionmember; - uint count = ShellApi.DragQueryFile(hdrop, -1, IntPtr.Zero, 0); - var files = new List(); - for (int i = 0; i < count; i++) + try { - var size = 512; - var sb = new StringBuilder(size); - ShellApi.DragQueryFile(hdrop, i, sb, size); - files.Add(sb.ToString()); + return FilesInDrop(td.unionmember); + } + finally + { + // The data object handed this medium over; it is ours to free. + ReleaseStgMedium(ref td); } - return files; } + + [DllImport("ole32.dll")] + private static extern void ReleaseStgMedium(ref STGMEDIUM medium); } } diff --git a/Win32/ShellApi.cs b/Win32/ShellApi.cs index ecf261f..026114a 100755 --- a/Win32/ShellApi.cs +++ b/Win32/ShellApi.cs @@ -352,9 +352,10 @@ public sealed class ShellApi public static extern bool Shel_NotifyIcon(int dwMesage, ref NOTIFYICONDATA lpData); [DllImport("shell32.dll", CharSet = CharSet.Auto)] public static extern void DragAcceptFiles(IntPtr hwnd, bool accept); - [DllImport("shell32.dll")] + // The Unicode entry point: the ANSI one turns names outside the code page into question marks. + [DllImport("shell32.dll", CharSet = CharSet.Unicode, EntryPoint = "DragQueryFileW")] public static extern uint DragQueryFile(IntPtr hDrop, int iFile, IntPtr lpszFile, int cch); - [DllImport("shell32.dll")] + [DllImport("shell32.dll", CharSet = CharSet.Unicode, EntryPoint = "DragQueryFileW")] public static extern uint DragQueryFile(IntPtr hDrop, int iFile, [Out] StringBuilder lpszFile, int cch); [DllImport("shell32.dll")] public static extern int SHGetPropertyStoreForWindow( diff --git a/Win32/ShellDrop.cs b/Win32/ShellDrop.cs new file mode 100644 index 0000000..04f30c4 --- /dev/null +++ b/Win32/ShellDrop.cs @@ -0,0 +1,168 @@ +using System; +using System.Runtime.InteropServices; +using System.Threading; + +namespace Bemo +{ + [ComImport, Guid("43826d1e-e718-42ee-bc55-a1e261c37bfe"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)] + public interface IShellItem + { + } + + [ComImport, Guid("947aab5f-0a5c-4c13-b4d6-4bf7836fc9f8"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)] + internal interface IFileOperation + { + uint Advise(IntPtr sink); + void Unadvise(uint cookie); + void SetOperationFlags(uint flags); + void SetProgressMessage([MarshalAs(UnmanagedType.LPWStr)] string message); + void SetProgressDialog(IntPtr dialog); + void SetProperties(IntPtr properties); + void SetOwnerWindow(IntPtr owner); + void ApplyPropertiesToItem(IShellItem item); + void ApplyPropertiesToItems([MarshalAs(UnmanagedType.IUnknown)] object items); + void RenameItem(IShellItem item, [MarshalAs(UnmanagedType.LPWStr)] string newName, IntPtr sink); + void RenameItems([MarshalAs(UnmanagedType.IUnknown)] object items, [MarshalAs(UnmanagedType.LPWStr)] string newName); + void MoveItem(IShellItem item, IShellItem folder, [MarshalAs(UnmanagedType.LPWStr)] string newName, IntPtr sink); + void MoveItems([MarshalAs(UnmanagedType.IUnknown)] object items, IShellItem folder); + void CopyItem(IShellItem item, IShellItem folder, [MarshalAs(UnmanagedType.LPWStr)] string copyName, IntPtr sink); + void CopyItems([MarshalAs(UnmanagedType.IUnknown)] object items, IShellItem folder); + void DeleteItem(IShellItem item, IntPtr sink); + void DeleteItems([MarshalAs(UnmanagedType.IUnknown)] object items); + uint NewItem(IShellItem folder, uint attributes, [MarshalAs(UnmanagedType.LPWStr)] string name, [MarshalAs(UnmanagedType.LPWStr)] string template, IntPtr sink); + void PerformOperations(); + [return: MarshalAs(UnmanagedType.Bool)] bool GetAnyOperationsAborted(); + } + + // Copies or moves dropped files as one shell operation: one progress dialog, one round of + // name conflicts, one step for Ctrl+Z in Explorer. + public static class FileOperation + { + private const uint FOF_ALLOWUNDO = 0x40, FOFX_ADDUNDORECORD = 0x20000000; + + [DllImport("shell32.dll", CharSet = CharSet.Unicode)] + private static extern void SHChangeNotify(int eventId, uint flags, string item1, IntPtr item2); + + [DllImport("shell32.dll", CharSet = CharSet.Unicode, PreserveSig = false)] + private static extern void SHCreateItemFromParsingName(string path, IntPtr bindContext, [In] ref Guid riid, out IShellItem item); + + [DllImport("user32.dll")] private static extern IntPtr GetForegroundWindow(); + [DllImport("user32.dll")] private static extern bool SetForegroundWindow(IntPtr hwnd); + [DllImport("user32.dll")] private static extern bool IsWindowVisible(IntPtr hwnd); + [DllImport("user32.dll")] private static extern uint GetWindowThreadProcessId(IntPtr hwnd, out uint processId); + + // The progress dialog takes the foreground and, closing, can leave it to no window or to + // another app's hidden one, so keys after a drop went nowhere. The folder's window gets it + // back then; a window the user has moved on to keeps it. + private static void ReturnFocus(IntPtr owner) + { + if (owner == IntPtr.Zero) return; + var foreground = GetForegroundWindow(); + if (foreground == owner) return; + uint process; + GetWindowThreadProcessId(foreground, out process); + var ours = foreground != IntPtr.Zero && process == (uint)System.Diagnostics.Process.GetCurrentProcess().Id; + if (foreground == IntPtr.Zero || ours || !IsWindowVisible(foreground)) SetForegroundWindow(owner); + } + + private static IShellItem Item(string path) + { + var riid = typeof(IShellItem).GUID; + SHCreateItemFromParsingName(path, IntPtr.Zero, ref riid, out var item); + return item; + } + + // Runs on the calling thread until the shell is done; false when cancelled or failed. + public static bool Run(string[] files, string folder, bool move, IntPtr owner) + { + try + { + var operation = (IFileOperation)Activator.CreateInstance(Type.GetTypeFromCLSID(new Guid("3ad05575-8857-4850-9277-11b85bdb8e09"))); + operation.SetOperationFlags(FOF_ALLOWUNDO | FOFX_ADDUNDORECORD); + if (owner != IntPtr.Zero) operation.SetOwnerWindow(owner); + var destination = Item(folder); + foreach (var file in files) + { + if (move) operation.MoveItem(Item(file), destination, null, IntPtr.Zero); + else operation.CopyItem(Item(file), destination, null, IntPtr.Zero); + } + operation.PerformOperations(); + return !operation.GetAnyOperationsAborted(); + } + catch (COMException) { return false; } + catch (ArgumentException) { return false; } + finally + { + // Open Explorer windows ignore the file system's own events for a shell operation + // and wait for its change notices, which did not reach them from this thread. Each + // folder touched is told to refresh, delivered before this returns. + const int SHCNE_UPDATEDIR = 0x1000; + const uint SHCNF_PATHW = 0x5, SHCNF_FLUSH = 0x1000; + var folders = new System.Collections.Generic.HashSet(StringComparer.OrdinalIgnoreCase) { folder }; + foreach (var file in files) + { + var parent = System.IO.Path.GetDirectoryName(file); + if (!string.IsNullOrEmpty(parent)) folders.Add(parent); + } + foreach (var changed in folders) SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_PATHW | SHCNF_FLUSH, changed, IntPtr.Zero); + ReturnFocus(owner); + } + } + + // A copy can take minutes; its own STA thread keeps the tabs responsive meanwhile. + public static Thread Start(string[] files, string folder, bool move, IntPtr owner) + { + var thread = new Thread(() => Run(files, folder, move, owner)) { Name = "WindowTabs file drop" }; + thread.SetApartmentState(ApartmentState.STA); + thread.Start(); + return thread; + } + } +} + +namespace Bemo +{ + // Explorer on Windows 11 keeps several folders in one window, one per tab; only the tab on + // show is where a drop on that window should go. + public static class ExplorerTabs + { + [ComImport, Guid("6d5140c1-7436-11ce-8034-00aa006009fa"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)] + private interface IOleServiceProvider + { + [PreserveSig] int QueryService([In] ref Guid service, [In] ref Guid riid, [MarshalAs(UnmanagedType.IUnknown)] out object found); + } + + // Only IOleWindow::GetWindow, the first method, is called. + [ComImport, Guid("000214E2-0000-0000-C000-000000000046"), InterfaceType(ComInterfaceType.InterfaceIsIUnknown)] + private interface IShellBrowser + { + [PreserveSig] int GetWindow(out IntPtr hwnd); + } + + [DllImport("user32.dll", CharSet = CharSet.Unicode)] + private static extern IntPtr FindWindowEx(IntPtr parent, IntPtr after, string className, string title); + + // The tab on show is the first of the window's tab children. + public static IntPtr ActiveTab(IntPtr explorer) + { + return FindWindowEx(explorer, IntPtr.Zero, "ShellTabWindowClass", null); + } + + // The tab window behind one of Shell.Application's windows; zero when it cannot tell. + public static IntPtr TabOf(object browser) + { + try + { + var provider = browser as IOleServiceProvider; + if (provider == null) return IntPtr.Zero; + var service = new Guid("4C96BE40-915C-11CF-99D3-00AA004AE837"); + var riid = typeof(IShellBrowser).GUID; + if (provider.QueryService(ref service, ref riid, out var found) != 0) return IntPtr.Zero; + var shellBrowser = found as IShellBrowser; + return shellBrowser != null && shellBrowser.GetWindow(out var hwnd) == 0 ? hwnd : IntPtr.Zero; + } + catch (COMException) { return IntPtr.Zero; } + catch (InvalidCastException) { return IntPtr.Zero; } + } + } +} diff --git a/WtProgram/ManagerViewService/SettingsControls.fs b/WtProgram/ManagerViewService/SettingsControls.fs index 01284ea..4f48c1f 100644 --- a/WtProgram/ManagerViewService/SettingsControls.fs +++ b/WtProgram/ManagerViewService/SettingsControls.fs @@ -1,4 +1,4 @@ -namespace Bemo +namespace Bemo open System open System.Drawing open System.Windows.Forms @@ -87,36 +87,6 @@ type SettingsInfoButton() as this = override this.OnMouseEnter(e) = base.OnMouseEnter(e); this.Invalidate() override this.OnMouseLeave(e) = base.OnMouseLeave(e); this.Invalidate() -module SettingsTextWrap = - /// The text as lines no wider than width: broken at spaces, after a path separator inside a - /// long word such as a file path (WordBreak would clip one), else between characters. - let lines (text:string) (font:Font) (width:int) = - let measure (part:string) = TextRenderer.MeasureText(part,font,Size(Int32.MaxValue,Int32.MaxValue),TextFormatFlags.NoPrefix).Width - let fits (part:string) = measure (part.TrimEnd()) <= width - // Pieces that each end where a line may break. - let pieces (paragraph:string) = - let result = ResizeArray() - let mutable start = 0 - for index in 0..paragraph.Length-1 do - if paragraph.[index]=' ' || paragraph.[index]='\\' || paragraph.[index]='/' then - result.Add(paragraph.Substring(start,index+1-start)) - start <- index+1 - if start Array.collect(fun paragraph -> - let line,lines = - pieces paragraph |> List.fold(fun (line:string,lines) piece -> - if fits (line+piece) then line+piece,lines - elif fits piece then piece,(if line="" then lines else line.TrimEnd()::lines) - else characters line piece lines) ("",[]) - line.TrimEnd()::lines |> List.rev |> Array.ofList) - |> List.ofArray - type private SettingsHelpPopup(message:string,font:Font) as this = inherit Form() // As wide as a short message needs, wrapping only past 470px. diff --git a/WtProgram/ManagerViewService/SettingsListPage.fs b/WtProgram/ManagerViewService/SettingsListPage.fs index c2c7b67..a008a31 100644 --- a/WtProgram/ManagerViewService/SettingsListPage.fs +++ b/WtProgram/ManagerViewService/SettingsListPage.fs @@ -20,22 +20,32 @@ type SettingsListPage(title:string, description:string, list:Control, actions:Co let status = new Label(AutoSize=false,AutoEllipsis=true,TextAlign=ContentAlignment.MiddleRight,Tag="muted",UseMnemonic=false) let actionRow = new FlowLayoutPanel(AutoSize=true,WrapContents=false,FlowDirection=FlowDirection.LeftToRight) let card = new Panel(Tag="surface") + /// Web links start the row; files on this PC, such as the crash log, stand apart at its right end. let linkRow = links |> Option.filter(List.isEmpty >> not) |> Option.map(fun links -> - let row = new FlowLayoutPanel(AutoSize=true,WrapContents=true) + let group () = new FlowLayoutPanel(AutoSize=false,WrapContents=true,Margin=Padding.Empty,Padding=Padding.Empty) + let web,files = group(),group() for text,url in links do // A file on this PC opens in Explorer, and is marked with a folder, not an arrow. let kind = if url.StartsWith("http",StringComparison.OrdinalIgnoreCase) then WebLink else FileLink - // The left margin matches the inset a Label gives its text, so links line up with the headings. - let link = new SettingsLink(text,kind,Margin=Padding(Dpi.scale 3,Dpi.scale 3,Dpi.scale 15,Dpi.scale 3)) + // Web links keep the inset a Label gives its text, lining up with the headings; files + // end flush with the page's right edge. + let margin = if kind=WebLink then Padding(Dpi.scale 3,Dpi.scale 3,Dpi.scale 15,Dpi.scale 3) + else Padding(Dpi.scale 15,Dpi.scale 3,0,Dpi.scale 3) + let link = new SettingsLink(text,kind,Margin=margin) link.Click.Add(fun _ -> try if IO.File.Exists(url) then Diagnostics.Process.Start("explorer.exe",sprintf "/select,\"%s\"" url) |> ignore else Diagnostics.Process.Start(url) |> ignore with _ -> ()) SettingsHover(link,url) |> ignore - row.Controls.Add(link) - row) + (if kind=WebLink then web else files).Controls.Add(link) + let row = new Panel(Margin=Padding.Empty) + row.Controls.AddRange([|web :> Control;files|]) + row,web,files) + let allLinks() = + linkRow |> Option.toList |> List.collect(fun (_,web,files) -> + [web;files] |> List.collect(fun group -> group.Controls |> Seq.cast |> List.ofSeq)) do this.Dock <- DockStyle.Fill this.DoubleBuffered <- true @@ -58,22 +68,20 @@ type SettingsListPage(title:string, description:string, list:Control, actions:Co card.Resize.Add(fun _ -> card.Invalidate()) this.Controls.AddRange([|heading :> Control;detail;actionRow;status;card|]) helpButton |> Option.iter(fun button -> this.Controls.Add(button)) - linkRow |> Option.iter(fun row -> this.Controls.Add(row)) + linkRow |> Option.iter(fun (row,_,_) -> this.Controls.Add(row)) extra |> Option.iter(fun control -> this.Controls.Add(control)) footer |> Option.iter(fun control -> this.Controls.Add(control)) // The link row is measured in OnLayout. The extra and footer blocks size themselves: rows only settle // once they have their real width, which can be after the pass that placed it, so a size // change lays the page out again afterwards rather than inside that pass. - linkRow |> Option.iter(fun row -> row.AutoSize <- false) Option.toList extra @ Option.toList footer |> List.iter(fun control -> control.SizeChanged.Add(fun _ -> if this.IsHandleCreated && not relayoutPending then relayoutPending <- true this.BeginInvoke(Action(fun () -> relayoutPending <- false; this.PerformLayout())) |> ignore)) ThemeBinding.watch this (fun () -> - linkRow |> Option.iter(fun row -> - let p = SettingsColors.current() - for link in row.Controls |> Seq.cast do link.LinkColor <- p.accent) + let p = SettingsColors.current() + for link in allLinks() do link.LinkColor <- p.accent list.Invalidate() card.Invalidate()) /// Short note above the list (scan progress, counts, errors). @@ -99,9 +107,18 @@ type SettingsListPage(title:string, description:string, list:Control, actions:Co elif detail.Visible then detail.Bottom+Dpi.scale 16 else heading.Bottom+Dpi.scale 16 match linkRow with - | Some row -> - let size = row.GetPreferredSize(Size(width,0)) - row.Bounds <- Rectangle(left,y,min width size.Width,size.Height) + | Some(row,web,files) -> + // Side by side when they fit; otherwise the files take the next line, still at the right. + let filesSize = if files.Controls.Count=0 then Size.Empty else files.GetPreferredSize(Size.Empty) + let gap = Dpi.scale 16 + let webSize = web.GetPreferredSize(Size(width,0)) + let oneLine = web.GetPreferredSize(Size.Empty) + let besideWeb = oneLine.Width+gap+filesSize.Width <= width + web.Bounds <- Rectangle(0,0,min width (if besideWeb then oneLine.Width else webSize.Width),if besideWeb then oneLine.Height else webSize.Height) + let filesTop = if besideWeb || web.Controls.Count=0 then 0 else web.Bottom + files.Bounds <- Rectangle(width-filesSize.Width,filesTop,filesSize.Width,filesSize.Height) + files.Visible <- files.Controls.Count>0 + row.Bounds <- Rectangle(left,y,width,max web.Bottom (if files.Visible then files.Bottom else 0)) y <- row.Bottom+Dpi.scale 14 | None -> () match extra with @@ -118,9 +135,10 @@ type SettingsListPage(title:string, description:string, list:Control, actions:Co let top = if noActions then match linkRow with - | Some row -> - let x = row.Right+Dpi.scale 16 - status.Bounds <- Rectangle(x,row.Top,max 0 (left+width-x),row.Height) + | Some(row,web,files) -> + let x = row.Left+web.Right+Dpi.scale 16 + let right = if files.Visible then row.Left+files.Left-Dpi.scale 16 else left+width + status.Bounds <- Rectangle(x,row.Top,max 0 (right-x),web.Height) y | None -> status.Bounds <- Rectangle(left,y,width,Dpi.scale 24) diff --git a/WtProgram/OleDropTarget.fs b/WtProgram/OleDropTarget.fs index 1c6d870..d0facf4 100755 --- a/WtProgram/OleDropTarget.fs +++ b/WtProgram/OleDropTarget.fs @@ -1,118 +1,161 @@ -namespace Bemo +namespace Bemo open System -open System.Collections -open System.Drawing -open System.Drawing.Drawing2D -open System.Drawing.Imaging -open System.Reflection -open System.IO +open System.Runtime.InteropServices open System.Windows.Forms open Bemo.Win32.Forms module OleDropLifetime = - [] + [] extern int RevokeDragDrop(IntPtr hwnd) - [] + [] extern void OleUninitialize() +/// Files dragged onto a tab: resting on a tab brings its window forward, and letting go on an +/// Explorer tab moves or copies them into that folder, which a line under the strip says. type OleDropTarget(ts:TabStrip) as this= - let Cell = CellScope() let os = OS() let window = os.windowFromHwnd(ts.hwnd) - let rButtonDown = Cell.create(false) - let lastTabHwndCell = Cell.create(None) let initialized = Ole2Api.OleInitialize(IntPtr.Zero)>=0 let registered = initialized && Ole2Api.RegisterDragDrop(window.hwnd, this)>=0 let mutable disposed = false + /// The drag's data and its files, from DragEnter until the drag ends. + let mutable data : Bemo.IDataObject option = None + let mutable files : string list = [] + let mutable rButtonDown = false + let mutable hoveredTab : IntPtr option = None + /// Looked up once per hovered tab: DragOver repeats while the pointer moves, and each + /// lookup asks every Explorer window across processes. + let mutable hoveredFolder : Shell.ShellFolder option = None + /// The source's drag image covered the tabs being aimed at, so a line under the strip says + /// what letting go does, in the app's theme. + let mutable label : TabTitleTip option = None + let mutable labelled = "" + /// A tab's window comes forward once the pointer rests on it, so sweeping a drag across + /// the strip does not flash every window it passes. + let activateTimer = new Timer(Interval=300) + /// The right-drag menu, themed like the tab menu; replaced, not disposed, from its own events. + let mutable dropMenu : ThemedContextMenu option = None + + let describe (effect:DragDropEffects) (pointerX:int) = + let text = + match effect,hoveredFolder with + | DragDropEffects.Move,Some folder -> (tr Strings.DropMenu.moveTo).Replace("%1",folder.title) + | DragDropEffects.Copy,Some folder -> (tr Strings.DropMenu.copyTo).Replace("%1",folder.title) + | _ -> "" + if text<>labelled then + labelled <- text + if text="" then label |> Option.iter(fun tip -> tip.hide()) + else + let tip = + match label with + | Some tip -> tip + | None -> + let tip = new TabTitleTip() + label <- Some tip + tip + let strip : Rect = ts.bounds + use font = System.Drawing.SystemFonts.MessageBoxFont + tip.show(text,font,System.Drawing.Rectangle(strip.x,strip.y,strip.size.width,strip.size.height),pointerX) + + let effectAt (keys:int) (pt:POINTL) (allowed:int) = + // Captured here: by OleDrop the right button is already up. + rButtonDown <- keys.hasFlag(MouseMessageKeyStateMask.MK_RBUTTON) + let tab = ts.tryHit(window.ptToClient(Pt(pt.x,pt.y))) |> Option.map(fun (Tab(hwnd),_) -> hwnd) + if tab<>hoveredTab then + hoveredTab <- tab + hoveredFolder <- tab |> Option.bind Shell.getShellFolder + activateTimer.Stop() + if tab.IsSome then activateTimer.Start() + let effect = + match hoveredFolder with + | Some folder -> + DropRules.effect (enum allowed) (keys.hasFlag(MouseMessageKeyStateMask.MK_CONTROL)) + (keys.hasFlag(MouseMessageKeyStateMask.MK_SHIFT)) files folder.path + | None -> DragDropEffects.None + describe effect pt.x + int effect + + do + activateTimer.Tick.Add(fun _ -> + activateTimer.Stop() + hoveredTab |> Option.iter(fun hwnd -> + let window = os.windowFromHwnd(hwnd) + // setForegroundWindow can fail while a key such as Ctrl is held during the drag, + // and then keeps failing until a new DragEnter. + window.setForegroundOrRestore(false) + window.bringToTop())) + interface IDisposable with member _.Dispose() = if not disposed then disposed <- true + activateTimer.Dispose() + dropMenu |> Option.iter(fun menu -> menu.Dispose()) + dropMenu <- None + label |> Option.iter(fun tip -> tip.Dispose()) + label <- None if registered then OleDropLifetime.RevokeDragDrop(window.hwnd) |> ignore if initialized then OleDropLifetime.OleUninitialize() - member this.dragEnd() = - rButtonDown.value <- false - lastTabHwndCell.set(None) + activateTimer.Stop() + describe DragDropEffects.None 0 + rButtonDown <- false + hoveredTab <- None + hoveredFolder <- None + data <- None + files <- [] interface IOleDropTarget with member x.OleDragEnter(pDataObj, grfKeyState, pt, pdwEffect) = + data <- match pDataObj with :? Bemo.IDataObject as data -> Some data | _ -> None + files <- data |> Option.map(fun data -> try List.ofSeq(OleHelper.QueryFiles(data)) with _ -> []) |> Option.defaultValue [] + let effect = effectAt grfKeyState pt pdwEffect + pdwEffect <- effect 0 - member x.OleDragOver(grfKeyState, pt, pdwEffect) = - //need to capture this here because it will be already released in the OleDrop handler - rButtonDown.value <- grfKeyState.hasFlag(MouseMessageKeyStateMask.MK_RBUTTON) - - let ptScreen = Pt(pt.x, pt.y) - let pt = window.ptToClient(Pt(pt.x, pt.y)) - - let tabHwnd = ts.tryHit(pt).map(fun(Tab(hwnd),part) -> hwnd) - let effect = tabHwnd.map <| fun hwnd -> - let shellFolder = Shell.getShellFolder hwnd - if shellFolder.IsSome then - if grfKeyState.hasFlag(MouseMessageKeyStateMask.MK_CONTROL) then - int(DragDropEffects.Copy) - else - int(DragDropEffects.Move) - else - int(DragDropEffects.None) - let effect = effect.def(int(DragDropEffects.None)) - if lastTabHwndCell.value <> tabHwnd then - lastTabHwndCell.set(tabHwnd) - tabHwnd.iter <| fun hwnd -> - let window = os.windowFromHwnd(hwnd) - //setForegroundWindow will fail sometimes if a key is pressed during DragOver - //like CTRL. we will be unable to call setForeground until a new DragEnter is generated - window.setForegroundOrRestore(false) - window.bringToTop() - pdwEffect <- effect + member x.OleDragOver(grfKeyState, pt, pdwEffect) = + pdwEffect <- effectAt grfKeyState pt pdwEffect 0 - member x.OleDragLeave() = + member x.OleDragLeave() = this.dragEnd() 0 - member x.OleDrop(pDataObj, grfKeyState, pt, pdwEffect) = - let initialEffect = pdwEffect + member x.OleDrop(pDataObj, grfKeyState, pt, pdwEffect) = + let allowed = enum pdwEffect let ptScreen = Pt(pt.x, pt.y) - let pt = window.ptToClient(ptScreen) - ts.tryHit(pt).iter <| fun(Tab(hwnd),part) -> - let shellFolder = Shell.getShellFolder hwnd - Shell.getShellFolder(hwnd).iter <| fun shellFolder -> - let files = List2(OleHelper.QueryFiles(pDataObj)) - let shellOp op = fun() -> - files.iter <| fun file -> - op(file) - let copy = shellOp <| fun file -> shellFolder.CopyHere(file, null) - let move = shellOp <| fun file -> shellFolder.MoveHere(file, null) - if rButtonDown.value then - Win32Menu.show window.hwnd ptScreen (List2([ - CmiRegular({ - text = tr Strings.DropMenu.copy - image = None - flags = List2() - click = copy - }) - CmiRegular({ - text = tr Strings.DropMenu.move - image = None - flags = List2() - click = move - }) - CmiSeparator - CmiRegular({ - text = tr Strings.Common.cancel - image = None - flags = List2() - click = fun() -> () - }) - ])) - elif grfKeyState.hasFlag(MouseMessageKeyStateMask.MK_CONTROL) then - copy() + // Read before effectAt, which records the keys of this call: the right button is up by now. + let menuFor = rButtonDown + let effect = effectAt grfKeyState pt pdwEffect + ts.tryHit(window.ptToClient(ptScreen)).iter <| fun(Tab(hwnd),part) -> + let folder = if hoveredTab=Some hwnd then hoveredFolder else Shell.getShellFolder hwnd + folder.iter <| fun folder -> + let dropped = Array.ofList files + let run move = FileOperation.Start(dropped,folder.path,move,hwnd) |> ignore + if menuFor then + // The menu offers what the source allows, once there is something to do. + if DropRules.effect allowed false false files folder.path<>DragDropEffects.None then + let item text click = CmiRegular({ text=text; image=None; flags=List2(); click=click }) + let items = List2([ + if allowed.HasFlag(DragDropEffects.Copy) then item (tr Strings.DropMenu.copy) (fun () -> run false) + if allowed.HasFlag(DragDropEffects.Move) then item (tr Strings.DropMenu.move) (fun () -> run true) + CmiSeparator + item (tr Strings.Common.cancel) ignore ]) + dropMenu |> Option.iter(fun menu -> menu.Dispose()) + // Open over the folder's window, which the drag has brought forward. + let menu = new ThemedContextMenu(items,ignore,(fun foreground -> foreground=hwnd)) + dropMenu <- Some menu + menu.Show(window.hwnd,ptScreen.x,ptScreen.y) else - move() + match enum effect with + | DragDropEffects.Move -> run true + | DragDropEffects.Copy -> run false + | _ -> () + // The shell does the work. Any other effect would let the source act on the files + // again; after a move it could delete what a skipped name conflict left behind. + pdwEffect <- int(DragDropEffects.None) this.dragEnd() 0 diff --git a/WtProgram/Shared/RuntimeDiagnostics.fs b/WtProgram/Shared/RuntimeDiagnostics.fs index 171a2f4..815a4e4 100644 --- a/WtProgram/Shared/RuntimeDiagnostics.fs +++ b/WtProgram/Shared/RuntimeDiagnostics.fs @@ -119,15 +119,6 @@ module RuntimeDiagnostics = let errorLogged = errorLoggedEvent.Publish let notifyErrorLogged() = errorLoggedEvent.Trigger() - /// The newest WindowTabsCrash.log, beside the exe or in AppData, where the crash handler writes it. - let crashLogPath() = - [AppDomain.CurrentDomain.BaseDirectory - IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData),"WindowTabs")] - |> List.map(fun folder -> IO.Path.Combine(folder,"WindowTabsCrash.log")) - |> List.filter IO.File.Exists - |> List.sortByDescending IO.File.GetLastWriteTime - |> List.tryHead - /// WindowTabsCrash.log: entries newest first, each starting with a line of dashes, then /// Time, Source, Version and OS, then the exception as .NET prints it. module CrashLog = @@ -186,6 +177,18 @@ module RuntimeDiagnostics = |> Option.defaultValue ""), JProperty("stack",JArray(stack |> Array.map box))) + /// The newest WindowTabsCrash.log with a crash in it, beside the exe or in AppData, where the + /// crash handler writes it. A log left empty is none: Support would offer a blank file. + let crashLogPath() = + [AppDomain.CurrentDomain.BaseDirectory + IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData),"WindowTabs")] + |> List.map(fun folder -> IO.Path.Combine(folder,"WindowTabsCrash.log")) + |> List.filter(fun path -> + try IO.File.Exists(path) && not (CrashLog.entries (IO.File.ReadAllText(path))).IsEmpty + with _ -> false) + |> List.sortByDescending IO.File.GetLastWriteTime + |> List.tryHead + /// The latest crashes, newest first, as far as they are safe to share; see CrashLog.summary. let private recentCrashes() = match crashLogPath() with diff --git a/WtProgram/Shared/SettingsColors.fs b/WtProgram/Shared/SettingsColors.fs index c145d8b..c5b7130 100644 --- a/WtProgram/Shared/SettingsColors.fs +++ b/WtProgram/Shared/SettingsColors.fs @@ -22,3 +22,33 @@ module SettingsColors = { background=Color.White; surface=Color.White; text=Color.FromRGB(0x191919) muted=Color.FromRGB(0x898883); disabledText=Color.FromRGB(0xBDBCB8); border=Color.FromRGB(0xE5E5E5); hover=Color.FromRGB(0xF3F3F3) accent=Color.FromRGB(0x2D79D7); selection=Color.FromRGB(0xE3E3E3) } + +module SettingsTextWrap = + /// The text as lines no wider than width: broken at spaces, after a path separator inside a + /// long word such as a file path (WordBreak would clip one), else between characters. + let lines (text:string) (font:Font) (width:int) = + let measure (part:string) = TextRenderer.MeasureText(part,font,Size(Int32.MaxValue,Int32.MaxValue),TextFormatFlags.NoPrefix).Width + let fits (part:string) = measure (part.TrimEnd()) <= width + // Pieces that each end where a line may break. + let pieces (paragraph:string) = + let result = ResizeArray() + let mutable start = 0 + for index in 0..paragraph.Length-1 do + if paragraph.[index]=' ' || paragraph.[index]='\\' || paragraph.[index]='/' then + result.Add(paragraph.Substring(start,index+1-start)) + start <- index+1 + if start Array.collect(fun paragraph -> + let line,lines = + pieces paragraph |> List.fold(fun (line:string,lines) piece -> + if fits (line+piece) then line+piece,lines + elif fits piece then piece,(if line="" then lines else line.TrimEnd()::lines) + else characters line piece lines) ("",[]) + line.TrimEnd()::lines |> List.rev |> Array.ofList) + |> List.ofArray diff --git a/WtProgram/Shared/Shell.fs b/WtProgram/Shared/Shell.fs index 44b7620..fd2dca3 100755 --- a/WtProgram/Shared/Shell.fs +++ b/WtProgram/Shared/Shell.fs @@ -1,17 +1,83 @@ -namespace Bemo +namespace Bemo open System open System.IO +open System.Reflection +open System.Windows.Forms +/// Explorer windows through the Shell.Application automation object, late bound so no +/// interop assemblies ship with the app. module Shell = + let private call (target:obj) name flags (args:obj[]) = + target.GetType().InvokeMember(name,flags,null,target,args) + let private get target name = call target name BindingFlags.GetProperty [||] + let private invoke target name args = call target name BindingFlags.InvokeMethod args + + /// A folder on disk an Explorer window shows, and the name it shows for it. + type ShellFolder = { path:string; title:string } + + /// The file system folder an Explorer window shows; None for any other window, and for + /// views such as This PC or the Recycle Bin. Each window is matched by its handle first, + /// so a view without a folder elsewhere cannot fail the search. A window holding several + /// Explorer tabs answers with the tab on show. let getShellFolder (hwnd:IntPtr) = - let shellWindows = SHDocVw.ShellWindowsClass() - let windows = List2(Seq.fromEnumerable shellWindows) - windows.tryPick <| fun window -> - match window with - | :? SHDocVw.ShellBrowserWindow as shellWindow -> - let folderView = shellWindow.Document :?> Shell32.IShellFolderViewDual - if shellWindow.HWND = int(hwnd) then - Some(folderView.Folder) - else - None - | _ -> None + let windowAt (windows:obj) index = + try + match invoke windows "Item" [|box index|] with + | null -> None + | window when Convert.ToInt64(get window "HWND")=hwnd.ToInt64() -> Some window + | _ -> None + with _ -> None + let folderOf window = + try + match get (get window "Document") "Folder" with + | null -> None + | folder -> + let self = get folder "Self" + if unbox(get self "IsFileSystem") then Some { path=string(get self "Path"); title=string(get folder "Title") } + else None + with _ -> None + if hwnd=IntPtr.Zero then None + else + try + match Type.GetTypeFromProgID("Shell.Application") with + | null -> None + | shellType -> + let windows = invoke (Activator.CreateInstance(shellType)) "Windows" [||] + let count = Convert.ToInt32(get windows "Count") + match List.init count id |> List.choose (windowAt windows) with + | [] -> None + | [single] -> folderOf single + | tabs -> + let active = ExplorerTabs.ActiveTab(hwnd) + tabs |> List.tryFind(fun tab -> active<>IntPtr.Zero && ExplorerTabs.TabOf(tab)=active) + |> Option.orElse (List.tryHead tabs) + |> Option.bind folderOf + with _ -> None + +/// What dropping files on an Explorer tab does, decided as Explorer decides: a move within one +/// drive and a copy across drives, Ctrl to copy and Shift to move. Files already in the folder, +/// such as those dragged back onto their own window's tab, are left where they are. +module DropRules = + let private same (a:string) (b:string) = String.Equals(a,b,StringComparison.OrdinalIgnoreCase) + let effect (allowed:DragDropEffects) ctrl shift (files:string list) (folder:string) = + try + let trimmed (path:string) = path.TrimEnd('\\') + let inFolder file = + match Path.GetDirectoryName(file:string) with + | null -> false + | parent -> same (trimmed parent) (trimmed folder) + let sameDrive = files |> List.forall(fun file -> same (Path.GetPathRoot(file:string)) (Path.GetPathRoot(folder))) + let wanted = + // A drive itself has no folder to leave; Explorer would only link to it. + let isRoot file = isNull (Path.GetDirectoryName(file:string)) + if files.IsEmpty || List.exists isRoot files || List.forall inFolder files || (ctrl && shift) then DragDropEffects.None + elif ctrl then DragDropEffects.Copy + elif shift || sameDrive then DragDropEffects.Move + else DragDropEffects.Copy + // A source that allows only one of the two gets that one, unless a key asked otherwise. + let other = if wanted=DragDropEffects.Move then DragDropEffects.Copy else DragDropEffects.Move + if wanted=DragDropEffects.None then DragDropEffects.None + elif allowed.HasFlag(wanted) then wanted + elif not ctrl && not shift && allowed.HasFlag(other) then other + else DragDropEffects.None + with _ -> DragDropEffects.None diff --git a/WtProgram/Shared/Strings.fs b/WtProgram/Shared/Strings.fs index 19332e5..778bc46 100644 --- a/WtProgram/Shared/Strings.fs +++ b/WtProgram/Shared/Strings.fs @@ -67,6 +67,9 @@ module Strings = module DropMenu = let copy = { en="Copy"; zh="复制"; ja="コピー" } let move = { en="Move"; zh="移动"; ja="移動" } + /// Under the strip while files are dragged over an Explorer tab; %1 is the folder's name. + let moveTo = { en="Move to %1"; zh="移动到 %1"; ja="%1 へ移動" } + let copyTo = { en="Copy to %1"; zh="复制到 %1"; ja="%1 へコピー" } /// Settings window chrome and page titles. module SettingsWindow = diff --git a/WtProgram/Shared/ThemedMenu.fs b/WtProgram/Shared/ThemedMenu.fs index 8d42692..1040582 100644 --- a/WtProgram/Shared/ThemedMenu.fs +++ b/WtProgram/Shared/ThemedMenu.fs @@ -71,6 +71,12 @@ type ThemeMenuRenderer(p:SettingsPalette) = /// Own image copies until the menu loop has finished closing, then dispatch the command. /// ownsForeground: windows whose activation must not close the menu, such as the tab's own /// window that the click which opened it is still bringing forward. +/// Whether any themed menu is open, on any thread, so a tab's title tip does not cover it. +module OpenMenus = + let private count = ref 0 + let change delta = lock count (fun () -> count.Value <- count.Value+delta) + let any () = lock count (fun () -> count.Value>0) + type ThemedContextMenu(items:List2,closed:unit -> unit,?ownsForeground:IntPtr -> bool) as this = inherit ContextMenuStrip() let palette = SettingsColors.current() @@ -82,6 +88,7 @@ type ThemedContextMenu(items:List2,closed:unit -> unit,?ownsFor /// and only afterwards raises the item's Click that records its command. let mutable chosen = false let mutable restoreOwner : obj option = None + let mutable counted = false let timer = new Timer(Interval=1) // Submenus open on hover after the Windows menu delay (400 ms here) through a timer that // only fires while WinForms still counts the item selected, which a menu of an app not in @@ -164,6 +171,9 @@ type ThemedContextMenu(items:List2,closed:unit -> unit,?ownsFor this.Dispose() run |> Option.iter(fun invoke -> invoke())) this.Opened.Add(fun _ -> + if not counted then + counted <- true + OpenMenus.change 1 mouseHook <- WinUserApi.SetWindowsHookEx(WindowHookTypes.WH_MOUSE_LL,mouseProc,IntPtr.Zero,0) if mouseHook=IntPtr.Zero then this.Close() @@ -178,6 +188,9 @@ type ThemedContextMenu(items:List2,closed:unit -> unit,?ownsFor ownsForeground |> Option.iter(fun owns -> if owns (WinUserApi.GetForegroundWindow()) then e.Cancel <- true)) // Put back what WinForms had, so no later menu inherits a strip that may be gone. this.Closed.Add(fun _ -> + if counted then + counted <- false + OpenMenus.change -1 hoverOpen.Stop() stopMouseHook() restoreOwner |> Option.iter(fun previous -> @@ -236,6 +249,10 @@ type ThemedContextMenu(items:List2,closed:unit -> unit,?ownsFor timer.Stop() hoverOpen.Dispose() base.Dispose(disposing) + // A menu gone without its Closed must not keep every title tip away. + if counted then + counted <- false + OpenMenus.change -1 if disposing then timer.Dispose() for image in images do image.Dispose() diff --git a/WtProgram/TabStrip.fs b/WtProgram/TabStrip.fs index 8030b53..eab1ac5 100755 --- a/WtProgram/TabStrip.fs +++ b/WtProgram/TabStrip.fs @@ -80,6 +80,10 @@ type TabStrip(monitor:ITabStripMonitor) as this = /// Waits out a press that handed the capture to the drag check, see WM_MOUSELEAVE. let captureWatch = new Timer(Interval=30) let mutable pointerSource : unit -> Point = fun () -> Cursor.Position + /// A cut-short title shows in full once the pointer rests on its tab, see pointTitle. + let titleTimer = new Timer(Interval=500) + let mutable titleTab : Tab option = None + let mutable titleTip : TabTitleTip option = None /// The full strip and the collapsed bar while an expand or collapse runs, so a frame only /// blends them; dropped whenever what they show changes. let mutable revealImages : (Img*Img) option = None @@ -116,6 +120,7 @@ type TabStrip(monitor:ITabStripMonitor) as this = showInsideExport.init() revealTimer.Tick.Add(fun _ -> this.stepReveal()) + titleTimer.Tick.Add(fun _ -> titleTimer.Stop(); this.showTitle()) captureWatch.Tick.Add(fun _ -> if WinUserApi.GetCapture()=IntPtr.Zero then captureWatch.Stop() @@ -201,11 +206,13 @@ type TabStrip(monitor:ITabStripMonitor) as this = this.window.trackMouseLeave() let hit = this.hit hoverCell.set(hit) + this.pointTitle(hit |> Option.map fst) let enableHoverActivate = Services.settings.getValue("enableHoverActivate").cast() if enableHoverActivate then hit.iter <| fun(hitTab, hitPart) -> monitor.tabActivate(hitTab) | MouseClick(pt, btn, action) -> this.setPt(Some(pt)) + this.hideTitle() this.hit.iter <| fun(hitTab, hitPart) -> match action with | MouseDown -> @@ -223,11 +230,46 @@ type TabStrip(monitor:ITabStripMonitor) as this = this.onMouse(action, pt, btn, (hitTab, hitPart)) hoverCell.set(this.hit) | MouseLeave -> + titleTab <- None + this.hideTitle() this.setPt(None) capturedCell.set(None) hoverCell.set(None) heldLayoutCell.set(None)) + member private this.hideTitle() = + titleTimer.Stop() + titleTip |> Option.iter(fun tip -> tip.hide()) + + /// From tab to tab, a title already showing moves straight to the next cut one; otherwise + /// it waits for the pointer to rest. A click puts it away until the pointer moves on. + member private this.pointTitle(tab:Tab option) = + if tab<>titleTab then + titleTab <- tab + let showing = titleTip |> Option.exists(fun tip -> tip.Visible) + this.hideTitle() + if tab.IsSome then + if showing then this.showTitle() else titleTimer.Start() + + member private this.showTitle() = + titleTab |> Option.iter(fun tab -> + let sprites : List2> = this.tabSprites + match sprites.list |> List.tryFind(fun (_,sprite) -> sprite.id=tab) with + | Some(_,sprite) when this.visible && not this.isShrunk && not (OpenMenus.any()) && sprite.titleCut -> + let tip = + match titleTip with + | Some tip -> tip + | None -> + let tip = new TabTitleTip() + titleTip <- Some tip + tip + let strip : Rect = this.bounds + tip.show(sprite.displayInfo.text,sprite.displayInfo.textFont, + Rectangle(strip.x,strip.y,strip.size.width,strip.size.height),pointerSource().X) + | _ -> ()) + + member internal _.titleTipShown = titleTip |> Option.exists(fun tip -> tip.Visible) + member private this.wndProc(msg:Win32Message) = // Where the frame on screen sits in the full strip: collapsed, expanded or part way. let mousePt() = msg.lParam.location.add(Pt(0,renderedOffset)) @@ -290,6 +332,7 @@ type TabStrip(monitor:ITabStripMonitor) as this = member internal _.renderCount = renderedFrames member private this.update() = + if not this.visible then this.hideTitle() let target = if this.isShrunk then 0.0 else 1.0 dropRevealImages() if this.visible then @@ -585,6 +628,9 @@ type TabStrip(monitor:ITabStripMonitor) as this = destroyingEvent.Trigger() revealTimer.Dispose() captureWatch.Dispose() + titleTimer.Dispose() + titleTip |> Option.iter(fun tip -> tip.Dispose()) + titleTip <- None dropRevealImages() normalFont.Dispose() renamedFont.Dispose() diff --git a/WtProgram/TabStripSprite.fs b/WtProgram/TabStripSprite.fs index 041787a..279b36a 100755 --- a/WtProgram/TabStripSprite.fs +++ b/WtProgram/TabStripSprite.fs @@ -466,6 +466,15 @@ type TabSprite<'id> = { let width = max 1 width Sz(width, this.contentHeight) + /// Whether the title shows only in part: cut by the ellipsis, or not drawn beside the icon. + member this.titleCut = + if this.onlyIcon then this.displayInfo.text<>"" + else + use image = new Bitmap(1,1) + use g = Graphics.FromImage(image) + use format = new StringFormat(FormatFlags=StringFormatFlags.NoWrap) + g.MeasureString(this.displayInfo.text,this.displayInfo.textFont,PointF.Empty,format).Width > float32 this.textSize.width + member this.tabTextBrush = new SolidBrush(this.textColor) diff --git a/WtProgram/TabTitleTip.fs b/WtProgram/TabTitleTip.fs new file mode 100644 index 0000000..06f8705 --- /dev/null +++ b/WtProgram/TabTitleTip.fs @@ -0,0 +1,83 @@ +namespace Bemo +open System +open System.Drawing +open System.Drawing.Drawing2D +open System.Windows.Forms + +/// A cut-short tab title in full, under the strip while the pointer rests on its tab. Themed +/// like the settings window's help, as the system tooltip stays light in a dark theme. +type TabTitleTip() = + inherit Form() + let mutable wrapped = "" + let mutable font : Font = null + let rounded (rect:RectangleF) radius = + let path = new GraphicsPath() + let d = min (radius*2.0f) (min rect.Width rect.Height) + path.AddArc(rect.Left,rect.Top,d,d,180.0f,90.0f) + path.AddArc(rect.Right-d,rect.Top,d,d,270.0f,90.0f) + path.AddArc(rect.Right-d,rect.Bottom-d,d,d,0.0f,90.0f) + path.AddArc(rect.Left,rect.Bottom-d,d,d,90.0f,90.0f) + path.CloseFigure() + path + let format = TextFormatFlags.NoPrefix + // No "as this": Form's constructor reads CreateParams before F# initialization finishes. + let mutable styled = false + + /// Above the strip and every window, never taking focus or the pointer. + override _.CreateParams = + let cp = base.CreateParams + cp.ExStyle <- cp.ExStyle ||| 0x08000000 ||| 0x00000080 ||| 0x00000008 ||| 0x00000020 + cp + override _.ShowWithoutActivation = true + + override this.OnPaintBackground(e) = e.Graphics.Clear((SettingsColors.current()).surface) + override this.OnPaint(e) = + let p = SettingsColors.current() + e.Graphics.SmoothingMode <- SmoothingMode.AntiAlias + use outline = rounded (RectangleF(0.0f,0.0f,float32(this.Width-1),float32(this.Height-1))) (float32(Dpi.scale 6)) + use pen = new Pen(p.border) + e.Graphics.DrawPath(pen,outline) + let inset = Dpi.scale 8 + TextRenderer.DrawText(e.Graphics,wrapped,this.Font,Rectangle(inset,Dpi.scale 5,this.Width-2*inset,this.Height-Dpi.scale 10),p.text,format) + + /// Below the strip at the pointer, or above it where the screen ends; wrapped past 470px. + member this.show(text:string,tabFont:Font,strip:Rectangle,pointerX:int) = + if not styled then + styled <- true + this.FormBorderStyle <- FormBorderStyle.None + this.StartPosition <- FormStartPosition.Manual + this.ShowInTaskbar <- false + this.DoubleBuffered <- true + if isNull font || font.Name<>tabFont.Name || font.Size<>tabFont.Size then + let previous = font + font <- new Font(tabFont,FontStyle.Regular) + this.Font <- font + if not (isNull previous) then previous.Dispose() + let inset = Dpi.scale 8 + let oneLine = TextRenderer.MeasureText(text,font,Size(Int32.MaxValue,Int32.MaxValue),format).Width + let width = min (Dpi.scale 470) (oneLine+2*inset) + wrapped <- String.Join("\n",SettingsTextWrap.lines text font (width-2*inset)) + let height = TextRenderer.MeasureText(wrapped,font,Size(Int32.MaxValue,Int32.MaxValue),format).Height+Dpi.scale 10 + // Kept on the strip's screen; a strip off every screen keeps its tip with it. + let area = + let screen = Screen.FromRectangle(strip).WorkingArea + if screen.IntersectsWith(strip) then screen else Rectangle(Int32.MinValue/2,Int32.MinValue/2,Int32.MaxValue,Int32.MaxValue) + let gap = Dpi.scale 4 + let below = strip.Bottom+gap + let y = if below+height<=area.Bottom then below else max area.Top (strip.Top-gap-height) + let x = max area.Left (min (pointerX-Dpi.scale 12) (area.Right-width)) + this.Bounds <- Rectangle(x,y,width,height) + use shape = rounded (RectangleF(0.0f,0.0f,float32 width,float32 height)) (float32(Dpi.scale 6)) + let previousRegion = this.Region + this.Region <- new Region(shape) + if not (isNull previousRegion) then previousRegion.Dispose() + this.Invalidate() + if not this.Visible then this.Show() + + member this.hide() = if this.Visible then this.Hide() + + override this.Dispose(disposing) = + if disposing && not (isNull font) then + font.Dispose() + font <- null + base.Dispose(disposing) diff --git a/WtProgram/WtProgram.fsproj b/WtProgram/WtProgram.fsproj index 4d47ff0..d5e9f71 100755 --- a/WtProgram/WtProgram.fsproj +++ b/WtProgram/WtProgram.fsproj @@ -1,4 +1,4 @@ - + WinExe @@ -31,7 +31,7 @@ true - $(OtherFlags) --standalone --staticlink:Win32 --staticlink:Newtonsoft.Json --staticlink:Interop.SHDocVw --staticlink:Interop.Shell32 + $(OtherFlags) --standalone --staticlink:Win32 --staticlink:Newtonsoft.Json $(NoWarn);2009;2011 @@ -82,6 +82,7 @@ + @@ -136,8 +137,6 @@ 13.0.1 already has the deep-nesting security fix. --> - - diff --git a/tests/Architecture.fsx b/tests/Architecture.fsx index 88be083..28e364f 100644 --- a/tests/Architecture.fsx +++ b/tests/Architecture.fsx @@ -376,6 +376,61 @@ let main() = check (not (NumericShortcutTarget.available [IntPtr(1)] (IntPtr(1)) 0)) "Current/only tab must pass through" check (NumericShortcutTarget.available [IntPtr(1);IntPtr(2)] (IntPtr(1)) 1) "Other tab must remain available" check (not (NumericShortcutTarget.available [IntPtr(1)] IntPtr.Zero 1)) "Missing tab must pass through" + // Dropping on tabs reaches Explorer late bound: no interop assembly ships, and a window + // that is not an Explorer folder is simply no target. + check (typeof.Assembly.GetReferencedAssemblies() |> Array.forall(fun name -> not (name.Name.StartsWith("Interop.")))) + "The app still references an interop assembly" + do + use plain = new Form(ShowInTaskbar=false) + check (Shell.getShellFolder IntPtr.Zero=None && Shell.getShellFolder plain.Handle=None) "A window without an Explorer folder was taken as a drop folder" + // Dropping decides as Explorer does, and leaves files already in the folder alone. + do + let any = DragDropEffects.Copy ||| DragDropEffects.Move ||| DragDropEffects.Link + let effect allowed ctrl shift files folder = DropRules.effect allowed ctrl shift files folder + check (effect any false false [@"C:\Work\a.txt"] @"C:\Archive"=DragDropEffects.Move) "A drop within one drive did not move" + check (effect any false false [@"D:\Work\a.txt"] @"C:\Archive"=DragDropEffects.Copy) "A drop from another drive did not copy" + check (effect any false false [@"\\server\share\a.txt"] @"\\SERVER\Share\Docs"=DragDropEffects.Move) "A drop within one network share did not move" + check (effect any true false [@"C:\Work\a.txt"] @"C:\Archive"=DragDropEffects.Copy) "Ctrl did not copy" + check (effect any false true [@"D:\Work\a.txt"] @"C:\Archive"=DragDropEffects.Move) "Shift did not move" + check (effect any true true [@"C:\Work\a.txt"] @"C:\Archive"=DragDropEffects.None) "Ctrl+Shift, a link, was taken as a move or copy" + check (effect any false false [@"C:\Work\a.txt"] @"c:\work\"=DragDropEffects.None) "Files dropped back on their own folder's tab were moved" + check (effect any false false [] @"C:\Archive"=DragDropEffects.None && effect any false false [@"D:\"] @"C:\Archive"=DragDropEffects.None) + "A drag without files, or of a whole drive, was accepted" + check (effect DragDropEffects.Copy false false [@"C:\Work\a.txt"] @"C:\Archive"=DragDropEffects.Copy && + effect DragDropEffects.Copy false true [@"C:\Work\a.txt"] @"C:\Archive"=DragDropEffects.None) + "A source that allows only copying was moved from, or a key it cannot honour was ignored" + // Several files go in one shell operation: copied ones stay behind, moved ones do not. + do + let root = Path.Combine(Path.GetTempPath(),"wt-drop-"+Guid.NewGuid().ToString("N")) + let source,target = Path.Combine(root,"source"),Path.Combine(root,"target") + Directory.CreateDirectory(source) |> ignore + Directory.CreateDirectory(target) |> ignore + try + let files = [| for name in ["a.txt";"b.txt"] -> Path.Combine(source,name) |] + for file in files do File.WriteAllText(file,file) + let copied = FileOperation.Run(files,target,false,IntPtr.Zero) + check (copied && files |> Array.forall(fun file -> File.Exists(file) && File.Exists(Path.Combine(target,Path.GetFileName(file))))) + "Dropped files were not all copied, or the originals went" + let moving = Path.Combine(source,"c.txt") + File.WriteAllText(moving,"c") + let moved = FileOperation.Run([|moving|],target,true,IntPtr.Zero) + check (moved && not (File.Exists(moving)) && File.Exists(Path.Combine(target,"c.txt"))) "A dropped file was not moved" + // A drop's paths were read through DragQueryFileA, which turned 小麦 into ??, so the + // file was not found and nothing moved. + let chinese = Path.Combine(source,"小麦-0.1.24-x64-setup.exe") + File.WriteAllText(chinese,"setup") + let path = Text.Encoding.Unicode.GetBytes(chinese + "\u0000\u0000") + let drop = Runtime.InteropServices.Marshal.AllocHGlobal(20 + path.Length) + try + // DROPFILES: the paths' offset, a point, fNC, and fWide for UTF-16 paths. + for offset,value in [0,20; 4,0; 8,0; 12,0; 16,1] do Runtime.InteropServices.Marshal.WriteInt32(drop,offset,value) + Runtime.InteropServices.Marshal.Copy(path,0,drop+nativeint 20,path.Length) + let read = OleHelper.FilesInDrop(drop) |> List.ofSeq + check (read=[chinese]) (sprintf "A dropped file's name outside the code page was not read whole: %A" read) + finally Runtime.InteropServices.Marshal.FreeHGlobal(drop) + check (FileOperation.Run([|chinese|],target,true,IntPtr.Zero) && File.Exists(Path.Combine(target,Path.GetFileName(chinese)))) + "A dropped file named outside the code page was not moved" + finally Directory.Delete(root,true) let mask = AltMenuMask.inputs() check (mask.Length=2 && mask.[0].mkhi.ki.wVk=0xE8s && mask.[1].mkhi.ki.dwFlags=SendInputConstants.KEYEVENTF_KEYUP && mask.[0].mkhi.ki.dwExtraInfo=IntPtr(AltMenuMask.marker)) "Alt menu mask must pair and mark injected events" check (capture.handle(WindowMessages.WM_KEYDOWN,0x31,Some 0)=(true,Some 0)) "Matched digit must be swallowed and activated" diff --git a/tests/Reliability.fsx b/tests/Reliability.fsx index e8178f5..b130ea0 100644 --- a/tests/Reliability.fsx +++ b/tests/Reliability.fsx @@ -248,6 +248,9 @@ let main() = (sprintf "Crash log is not newest first: %A" times) let short = RuntimeDiagnostics.CrashLog.prepend (entry "2026-01-03 09:00:00" "System.NullReferenceException") (IO.File.ReadAllText(crashLog)) 800 check (short.Contains("2026-01-03") && not (short.Contains("2026-01-01"))) "Crash log limit did not drop the oldest entries" + // A log left empty offers nothing to open. + IO.File.WriteAllText(crashLog,"") + check (RuntimeDiagnostics.crashLogPath()<>Some crashLog) "An empty crash log was offered to open" finally match existingLog with | Some text -> IO.File.WriteAllText(crashLog,text) diff --git a/tests/TabInteraction.fsx b/tests/TabInteraction.fsx index 4c83927..8145064 100644 --- a/tests/TabInteraction.fsx +++ b/tests/TabInteraction.fsx @@ -80,6 +80,7 @@ let main() = dot.Dispose() menu.Show(Point(40,40)) Application.DoEvents() + check (OpenMenus.any()) "An open menu was not counted, so a title tip could cover it" // Pointing at an item with a submenu opens it after a short pause of our own, not the // Windows menu delay through WinForms' timer, which a menu of an app behind could lose. // The pointer entering an item, as WinForms reports it: HandleMouseEnter raises MouseEnter. @@ -111,6 +112,7 @@ let main() = first.PerformClick() menu.Close() check (closed && selected=0 && not menu.IsDisposed) "Menu command or disposal ran inside the close event" + check (not (OpenMenus.any())) "A closed menu still kept title tips away" let deadline = DateTime.UtcNow.AddSeconds(2.0) while not menu.IsDisposed && DateTime.UtcNow.GetProperty("titleTipShown",flags).GetValue(strip) :?> bool + let waiting () = (typeof.GetField("titleTimer",flags).GetValue(strip) :?> Timer).Enabled + let rest () = typeof.GetMethod("showTitle",flags).Invoke(strip,[||]) |> ignore + hover 60 + check (waiting() && not (shown())) "A cut-short title did not wait for the pointer to rest" + rest() + check (shown()) "A cut-short title did not show in full after a rest" + hover 460 + check (shown()) "Moving between cut-short titles did not show the next one at once" + hover 260 + rest() + check (not (shown())) "A title that fits showed a tip" + // A menu open over the strip, such as a right-drag's, is not covered by a tip. + hover 60 + OpenMenus.change 1 + rest() + let underMenu = shown() + OpenMenus.change -1 + check (not underMenu) "A title tip covered an open menu" + hover 260 + hover 60 + check (waiting()) "Returning to a cut-short title did not wait to show it again" + rest() + send WindowMessages.WM_LBUTTONDOWN (Pt(Dpi.scale 60,Dpi.scale 14)) + send WindowMessages.WM_LBUTTONUP (Pt(Dpi.scale 60,Dpi.scale 14)) + hover 61 + check (not (shown()) && not (waiting())) "The tip came back after a click on its tab" + hover 460 + rest() + send WindowMessages.WM_MOUSELEAVE Pt.empty + check (not (shown()) && not (waiting())) "The tip stayed after the pointer left the strip" + for id in [101;102;103] do titled id "" let os = OS() let shadow = os.windowsInZorder.list |> List.find(fun window -> window.parent.hwnd=strip.hwnd)