1(* 2 Copyright (c) 2007, 2015, 2019 3 David C.J. Matthews 4 5 This library is free software; you can redistribute it and/or 6 modify it under the terms of the GNU Lesser General Public 7 License version 2.1 as published by the Free Software Foundation. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18 19(* Common controls. *) 20structure CommonControls: 21sig 22 type HWND and HINSTANCE and HBITMAP 23 val InitCommonControls: unit->unit 24 25 structure ToolbarStyle: 26 sig 27 include BIT_FLAGS where type flags = Window.Style.flags 28 val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags 29 and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags 30 and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags 31 and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags 32 and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags 33 and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags 34 and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags 35 and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags 36 and TBSTYLE_BUTTON:flags and TBSTYLE_SEP:flags and TBSTYLE_CHECK:flags 37 and TBSTYLE_GROUP:flags and TBSTYLE_CHECKGROUP:flags and TBSTYLE_DROPDOWN:flags 38 and TBSTYLE_AUTOSIZE:flags and TBSTYLE_NOPREFIX:flags and TBSTYLE_TOOLTIPS:flags 39 and TBSTYLE_WRAPABLE:flags and TBSTYLE_ALTDRAG:flags and TBSTYLE_FLAT:flags 40 and TBSTYLE_LIST:flags and TBSTYLE_CUSTOMERASE:flags and TBSTYLE_REGISTERDROP:flags 41 and TBSTYLE_TRANSPARENT:flags and BTNS_BUTTON:flags and BTNS_SEP:flags 42 and BTNS_CHECK:flags and BTNS_GROUP:flags and BTNS_CHECKGROUP:flags 43 and BTNS_DROPDOWN:flags and BTNS_AUTOSIZE:flags and BTNS_NOPREFIX:flags 44 and BTNS_SHOWTEXT:flags and BTNS_WHOLEDROPDOWN:flags 45 end 46 47 structure ToolbarState: 48 sig 49 include BIT_FLAGS 50 val TBSTATE_CHECKED: flags and TBSTATE_PRESSED: flags and TBSTATE_ENABLED: flags 51 and TBSTATE_HIDDEN: flags and TBSTATE_INDETERMINATE: flags and TBSTATE_WRAP: flags 52 and TBSTATE_ELLIPSES: flags and TBSTATE_MARKED : flags 53 end 54 55 datatype ToolbarResource = 56 ToolbarHandle of HBITMAP | ToolbarResource of HINSTANCE*Resource.RESID 57 58 datatype ParentType = datatype Window.ParentType 59 60 type TBBUTTON = { iBitmap: int, idCommand: int, fsState: ToolbarState.flags, 61 fsStyle: ToolbarStyle.flags, dwData: int, isString: int}; 62 val CreateToolbarEx: { relation: ParentType, style: ToolbarStyle.flags, nBitmaps: int, 63 bitmaps: ToolbarResource, buttons: TBBUTTON list, 64 xButton: int, yButton: int, xBitmap: int, yBitmap: int} -> HWND 65 val CreateStatusWindow: { relation: ParentType, style: Window.Style.flags, text: string } -> HWND 66 67 val SB_SIMPLEID: int 68 69 structure StatusBarType: 70 sig 71 include BIT_FLAGS 72 val SBT_NOBORDERS: flags and SBT_OWNERDRAW: flags 73 and SBT_POPOUT: flags and SBT_RTLREADING : flags and SBT_TOOLTIPS: flags 74 end 75 76 (* Creating messages here is just too complicated. It's easier to do this with 77 functions to send the message and deal with the result. *) 78 val StatusBarSetText: {hWnd: HWND, iPart: int, uType: StatusBarType.flags, text: string}->int 79 val StatusBarGetText: HWND*int -> string * StatusBarType.flags 80 val StatusBarSetParts: HWND * int list -> bool 81end = 82struct 83 datatype ParentType = datatype Window.ParentType 84 85 local 86 open Foreign 87 open Globals 88 open Base 89 90 in 91 type HWND = HWND and HINSTANCE = HINSTANCE and HBITMAP = HBITMAP 92 93 val InitCommonControls = winCall0(comctl "InitCommonControls") () cVoid 94 95 (* Toolbar style is a mess. The TBBUTTON structure allows only a single 96 byte for the style but some of the values exceed that. Apparently 97 it's necessary to use CreateWindowEx for those. *) 98 structure ToolbarStyle = 99 struct 100 open Window.Style (* Include all the windows styles. *) 101 val TBSTYLE_BUTTON = fromWord 0wx0 102 val TBSTYLE_SEP = fromWord 0wx1 103 val TBSTYLE_CHECK = fromWord 0wx2 104 val TBSTYLE_GROUP = fromWord 0wx4 105 val TBSTYLE_CHECKGROUP = flags[TBSTYLE_GROUP,TBSTYLE_CHECK] 106 val TBSTYLE_DROPDOWN = fromWord 0wx8 107 val TBSTYLE_AUTOSIZE = fromWord 0wx10 108 val TBSTYLE_NOPREFIX = fromWord 0wx20 109 val TBSTYLE_TOOLTIPS = fromWord 0wx100 110 val TBSTYLE_WRAPABLE = fromWord 0wx200 111 112 val TBSTYLE_ALTDRAG = fromWord 0wx400 113 114 val TBSTYLE_FLAT = fromWord 0wx800 115 val TBSTYLE_LIST = fromWord 0wx1000 116 val TBSTYLE_CUSTOMERASE = fromWord 0wx2000 117 val TBSTYLE_REGISTERDROP = fromWord 0wx4000 118 val TBSTYLE_TRANSPARENT = fromWord 0wx8000 119 (* -- These are used with TB_SETEXTENDEDSTYLE/TB_GETEXTENDEDSTYLE 120 val TBSTYLE_EX_DRAWDDARROWS = fromWord 0wx00000001 121 val TBSTYLE_EX_MIXEDBUTTONS = fromWord 0w8 122 val TBSTYLE_EX_HIDECLIPPEDBUTTONS = fromWord 0w16 123 val TBSTYLE_EX_DOUBLEBUFFER = fromWord 0wx80*) 124 val BTNS_BUTTON = TBSTYLE_BUTTON 125 val BTNS_SEP = TBSTYLE_SEP 126 val BTNS_CHECK = TBSTYLE_CHECK 127 val BTNS_GROUP = TBSTYLE_GROUP 128 val BTNS_CHECKGROUP = TBSTYLE_CHECKGROUP 129 val BTNS_DROPDOWN = TBSTYLE_DROPDOWN 130 val BTNS_AUTOSIZE = TBSTYLE_AUTOSIZE 131 val BTNS_NOPREFIX = TBSTYLE_NOPREFIX 132 val BTNS_SHOWTEXT = fromWord 0wx0040 133 val BTNS_WHOLEDROPDOWN = fromWord 0wx0080 134 135 val all = flags[Window.Style.all, TBSTYLE_BUTTON, TBSTYLE_SEP, TBSTYLE_CHECK, 136 TBSTYLE_GROUP, TBSTYLE_DROPDOWN, TBSTYLE_AUTOSIZE, TBSTYLE_NOPREFIX, 137 TBSTYLE_TOOLTIPS, TBSTYLE_WRAPABLE, TBSTYLE_ALTDRAG, TBSTYLE_FLAT, 138 TBSTYLE_LIST, TBSTYLE_CUSTOMERASE, TBSTYLE_TRANSPARENT, 139 BTNS_SHOWTEXT, BTNS_WHOLEDROPDOWN] 140 141 val intersect = 142 List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all 143 end 144 145 structure ToolbarState:> 146 sig 147 include BIT_FLAGS 148 val TBSTATE_CHECKED: flags and TBSTATE_PRESSED: flags and TBSTATE_ENABLED: flags 149 and TBSTATE_HIDDEN: flags and TBSTATE_INDETERMINATE: flags and TBSTATE_WRAP: flags 150 and TBSTATE_ELLIPSES: flags and TBSTATE_MARKED : flags 151 val cToolBarState: flags conversion (* Only used internally *) 152 end = 153 struct 154 open Word8 155 type flags = Word8.word 156 val toWord = toLargeWord 157 and fromWord = fromLargeWord 158 val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 159 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 160 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 161 fun clear (fl1, fl2) = andb(notb fl1, fl2) 162 163 val TBSTATE_CHECKED = 0w1 164 val TBSTATE_PRESSED = 0w2 165 val TBSTATE_ENABLED = 0w4 166 val TBSTATE_HIDDEN = 0w8 167 val TBSTATE_INDETERMINATE = 0wx10 168 val TBSTATE_WRAP = 0wx20 169 val TBSTATE_ELLIPSES = 0wx40 170 val TBSTATE_MARKED = 0wx80 171 val all = flags[TBSTATE_CHECKED, TBSTATE_PRESSED, TBSTATE_ENABLED, TBSTATE_HIDDEN, 172 TBSTATE_INDETERMINATE, TBSTATE_WRAP, TBSTATE_ELLIPSES, TBSTATE_MARKED] 173 174 val intersect = List.foldl (fn (a, b) => andb(a, b)) all 175 176 val cToolBarState = cUint8w (*Must be a byte*) 177 end 178 179 180 datatype ToolbarResource = 181 ToolbarHandle of HBITMAP | ToolbarResource of HINSTANCE*Resource.RESID 182 183 type TBBUTTON = { iBitmap: int, idCommand: int, fsState: ToolbarState.flags, 184 fsStyle: ToolbarStyle.flags, dwData: int, isString: int} 185 local 186 val TBBUTTON = 187 cStruct6(cInt, cInt, ToolbarState.cToolBarState(*byte*), cUint8w, cDWORD_PTR, cINT_PTR) 188 val {ctype={size=sizeTBB, ...}, ...} = breakConversion TBBUTTON 189 190 val createToolbarEx = winCall13 (comctl "CreateToolbarEx") 191 (cHWND,cDWORDw,cUint,cInt,cHINSTANCE, cPointer ,cPointer,cInt,cInt,cInt,cInt,cInt,cUint) cHWND 192 val list2vec = list2Vector TBBUTTON 193 194 in 195 fun CreateToolbarEx { relation: ParentType, style: ToolbarStyle.flags, nBitmaps: int, 196 bitmaps: ToolbarResource, buttons: TBBUTTON list, 197 xButton: int, yButton: int, xBitmap: int, yBitmap: int}: HWND = 198 let 199 (* This must be a child and WS_CHILD is included by default *) 200 val (parent, childId, styleWord) = 201 case relation of 202 ChildWindow{parent, id} => (parent, id, WinBase.Style.toWord style) 203 | _ => raise Fail "CreateToolbarEx: relation must be ChildWindow" 204 205 fun mapToStruct({iBitmap, idCommand, fsState, fsStyle, dwData, isString}:TBBUTTON) = 206 (iBitmap, idCommand, fsState, Word8.fromLargeWord(ToolbarStyle.toWord fsStyle), dwData, isString) 207 208 val (buttonVec, nButtons) = list2vec (map mapToStruct buttons) 209 (* The wBMID argument may be either a resource identifier or a bitmap handle. *) 210 val (hBMInst, wBMID, freeStr) = 211 case bitmaps of 212 ToolbarHandle hbm => (hinstanceNull, voidStarOfHandle hbm, Memory.null) 213 | ToolbarResource(hi, IdAsInt wb) => (hi, Memory.sysWord2VoidStar(SysWord.fromInt wb), Memory.null) 214 | ToolbarResource(hi, IdAsString str) => let val s = toCstring str in (hi, s, s) end 215 216 val res = 217 createToolbarEx(parent, Word32.fromLargeWord styleWord, childId, nBitmaps, 218 hBMInst, wBMID, buttonVec, nButtons, xButton, yButton, xBitmap, yBitmap, 219 Word.toInt sizeTBB) 220 handle ex => (Memory.free freeStr; Memory.free buttonVec; raise ex) 221 val () = Memory.free freeStr and () = Memory.free buttonVec 222 in 223 checkResult(not(isHNull res)); 224 res 225 end 226 end 227 228 local 229 val createStatusWindow = winCall4 (comctl "CreateStatusWindowA") (cLong,cString,cHWND,cUint) cHWND 230 in 231 fun CreateStatusWindow{ relation: ParentType, style: Window.Style.flags, text: string } = 232 let 233 val (parent, childId, styleWord) = 234 case relation of 235 ChildWindow{parent, id} => 236 let open WinBase.Style in (parent, id, toWord(flags[WS_CHILD, style])) end 237 | _ => raise Fail "CreateStatusWindow: relation must be ChildWindow" 238 val res = createStatusWindow(LargeWord.toInt styleWord, text, parent, childId) 239 in 240 checkResult(not(isHNull res)); 241 res 242 end 243 end 244 245 val SB_SIMPLEID = 0x00ff 246 247 structure StatusBarType: 248 sig 249 include BIT_FLAGS 250 val SBT_NOBORDERS: flags and SBT_OWNERDRAW: flags 251 and SBT_POPOUT: flags and SBT_RTLREADING : flags and SBT_TOOLTIPS: flags 252 end = 253 struct 254 type flags = SysWord.word 255 fun toWord f = f 256 fun fromWord f = f 257 val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 258 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 259 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 260 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) 261 262 val SBT_NOBORDERS = 0w256 263 val SBT_OWNERDRAW = 0wx1000 264 val SBT_POPOUT = 0w512 265 val SBT_RTLREADING = 0w1024 266 val SBT_TOOLTIPS = 0wx0800 267 val all = flags[SBT_NOBORDERS, SBT_OWNERDRAW, SBT_POPOUT, SBT_RTLREADING, SBT_TOOLTIPS] 268 269 val intersect = 270 List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all 271 end; 272 273 val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTR, cPointer) cUint 274 275 fun StatusBarSetText{hWnd, iPart, uType, text}:int = 276 let 277 val s = toCstring text 278 val res = sendMsg(hWnd, 0x401, LargeWord.toInt(LargeWord.orb(LargeWord.fromInt iPart, StatusBarType.toWord uType)), s) 279 handle ex => (Memory.free s; raise ex) 280 val () = Memory.free s 281 in 282 res 283 end 284 285 fun StatusBarGetText(hWnd, iPart): string * StatusBarType.flags = 286 let 287 val result1 = Word32.fromInt(sendMsg(hWnd, 0x403, iPart, Memory.null)) 288 val length = LOWORD result1 289 val flags = StatusBarType.fromWord(Word.toLargeWord(HIWORD result1)) 290 in 291 if StatusBarType.anySet(flags, StatusBarType.SBT_OWNERDRAW) 292 then ("", flags) 293 else 294 let 295 open Memory 296 val buff = malloc (length+0w1) 297 val reply = 298 sendMsg(hWnd, 0x402, iPart, buff) 299 handle ex => (free buff; raise ex) 300 in 301 (if reply = 0 then "" else fromCstring buff, flags) before free buff 302 end 303 end 304 305 fun StatusBarSetParts(hWnd, parts: int list): bool = 306 let 307 val (vec, nParts) = list2Vector cInt parts 308 open Memory 309 val res = sendMsg(hWnd, 0x404, nParts, vec) 310 handle ex => (free vec; raise ex) 311 val () = free vec 312 in 313 res <> 0 314 end 315 316 (* 317 318 | compileMessage (SB_GETTEXT { iPart: int, text: string ref, length: int }) = 319 (* Another case, like LB_GETTEXT. where we don't know the length so we 320 add an extra argument to the ML message. *) 321 (0x402, toCint iPart, address(alloc (length+1) Cchar)*) 322 323 324(* | compileMessage (SB_SETTEXT { iPart: int, uType: StatusBarType, text: string}) = 325 (0x401, toCint 0, toCstring text) 326 | compileMessage (SB_GETTEXT _) = (0x402, toCint 0, toCInt 0) 327 | compileMessage (SB_GETTEXTLENGTH _) = (0x403, toCint 0, toCInt 0) 328 | compileMessage (SB_SETPARTS _) = (0x404, toCint 0, toCInt 0) 329 | compileMessage (SB_GETPARTS _) = (0x406, toCint 0, toCInt 0) 330 | compileMessage (SB_GETBORDERS _) = (0x407, toCint 0, toCInt 0) 331 | compileMessage (SB_SETMINHEIGHT _) = (0x408, toCint 0, toCInt 0) 332 | compileMessage (SB_SIMPLE _) = (0x409, toCint 0, toCInt 0) 333 | compileMessage (SB_GETRECT _) = (0x40A, toCint 0, toCInt 0)*) 334 335 end 336end; 337