MMaurice FlanaganInitial
59b956f7创建于 2018年7月20日历史提交
namespace Bemo
open System
open System.Drawing

type ContextMenuItem =
    | CmiRegular of CmiRegular
    | CmiSeparator
    | CmiPopUp of CmiPopUp

and CmiRegular = {
    text: string
    image: Option<Img>
    click: unit -> unit
    flags: List2<int>
    }

and CmiPopUp = {
    text: string
    image: Option<Img>
    items: List2<ContextMenuItem>
    }

module Win32Menu =        
    let show (hwnd:IntPtr) (pt:Pt) (items:List2<_>) =
        let id = ref 0
        
        let nextId() = 
            id := id.Value + 1
            id.Value
        
        let handlers = ref (Map2())
        
        let menus = ref (Set2())
        
        let rec createMenu (items:List2<_>) =
            let hMenu = WinUserApi.CreatePopupMenu()
            let addImage id (image:Option<Img>) =
                image.iter <| fun image ->
                    let hBitmap = image.resize(Sz(16,16)).hbitmap
                    WinUserApi.SetMenuItemBitmaps(hMenu, id, 1, hBitmap, hBitmap).ignore                  
            menus := menus.Value.add hMenu
            items.iter <| fun item ->
                match item with
                | CmiRegular(item) ->
                    let id = nextId()
                    WinUserApi.AppendMenu(hMenu, 
                        item.flags.append(MenuFlags.MF_STRING).reduce((|||)),
                        id, item.text).ignore
                    addImage id item.image
                    handlers := handlers.Value.add id item.click
                | CmiSeparator ->
                    let id = nextId()
                    WinUserApi.AppendMenu(hMenu, MenuFlags.MF_SEPARATOR, id, "").ignore
                | CmiPopUp(item) ->
                    let hSubMenu = createMenu item.items
                    WinUserApi.AppendMenu(hMenu, MenuFlags.MF_POPUP, hSubMenu, item.text).ignore
                    addImage hSubMenu item.image
            int(hMenu)

        let hMenu = IntPtr(createMenu items)
        let id = WinUserApi.TrackPopupMenuEx(hMenu, TrackPopupMenuFlags.TPM_RETURNCMD, pt.x, pt.y, hwnd, IntPtr.Zero)
        if id <> 0 then
            match handlers.Value.tryFind id with
            | Some(click) -> click()
            | None -> ()
        menus.Value.items.iter <| fun hMenu ->
            WinUserApi.DestroyMenu(hMenu).ignore