1(* 2 Copyright (c) 2001, 2015 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(* Common dialogues. *) 19structure CommonDialog : 20 sig 21 type HWND and HDC and COLORREF = Color.COLORREF and HINSTANCE 22 type POINT = { x: int, y: int } 23 type RECT = { left: int, top: int, right: int, bottom: int } 24 25 (* Error codes *) 26 datatype CDERR = 27 DIALOGFAILURE 28 | GENERALCODES 29 | STRUCTSIZE 30 | INITIALIZATION 31 | NOTEMPLATE 32 | NOHINSTANCE 33 | LOADSTRFAILURE 34 | FINDRESFAILURE 35 | LOADRESFAILURE 36 | LOCKRESFAILURE 37 | MEMALLOCFAILURE 38 | MEMLOCKFAILURE 39 | NOHOOK 40 | REGISTERMSGFAIL 41 42 | PRINTERCODES 43 | SETUPFAILURE 44 | PARSEFAILURE 45 | RETDEFFAILURE 46 | LOADDRVFAILURE 47 | GETDEVMODEFAIL 48 | INITFAILURE 49 | NODEVICES 50 | NODEFAULTPRN 51 | DNDMMISMATCH 52 | CREATEICFAILURE 53 | PRINTERNOTFOUND 54 | DEFAULTDIFFERENT 55 56 | CHOOSEFONTCODES 57 | NOFONTS 58 | MAXLESSTHANMIN 59 60 | FILENAMECODES 61 | SUBCLASSFAILURE 62 | INVALIDFILENAME 63 | BUFFERTOOSMALL 64 65 | FINDREPLACECODES 66 | BUFFERLENGTHZERO 67 68 | CHOOSECOLORCODES 69 70 val CommDlgExtendedError : unit -> CDERR 71 72 (* ChooseColor *) 73(* 74 structure ChooseColorFlags : 75 sig 76 include BIT_FLAGS 77 val CC_ANYCOLOR : flags 78 val CC_FULLOPEN : flags 79 val CC_PREVENTFULLOPEN : flags 80 val CC_RGBINIT : flags 81 val CC_SHOWHELP : flags 82 val CC_SOLIDCOLOR : flags 83 end 84 85 type CHOOSECOLOR = 86 { 87 owner: HWND option, 88 result: COLORREF, 89 customColors: COLORREF list, 90 flags: ChooseColorFlags.flags 91 } 92 93 val ChooseColor : CHOOSECOLOR -> CHOOSECOLOR option 94 95 96 (* ChooseFont *) 97 98 structure ChooseFontFlags : 99 sig 100 include BIT_FLAGS 101 val CF_ANSIONLY : flags 102 val CF_APPLY : flags 103 val CF_BOTH : flags 104 val CF_EFFECTS : flags 105 val CF_FIXEDPITCHONLY : flags 106 val CF_FORCEFONTEXIST : flags 107 val CF_NOFACESEL : flags 108 val CF_NOOEMFONTS : flags 109 val CF_NOSCRIPTSEL : flags 110 val CF_NOSIMULATIONS : flags 111 val CF_NOSIZESEL : flags 112 val CF_NOSTYLESEL : flags 113 val CF_NOVECTORFONTS : flags 114 val CF_NOVERTFONTS : flags 115 val CF_PRINTERFONTS : flags 116 val CF_SCALABLEONLY : flags 117 val CF_SCREENFONTS : flags 118 val CF_SCRIPTSONLY : flags 119 val CF_SELECTSCRIPT : flags 120 val CF_SHOWHELP : flags 121 val CF_TTONLY : flags 122 val CF_WYSIWYG : flags 123 end 124 125 structure ChooseFontTypes : 126 sig 127 include BIT_FLAGS 128 val BOLD_FONTTYPE : flags 129 val ITALIC_FONTTYPE : flags 130 val PRINTER_FONTTYPE : flags 131 val REGULAR_FONTTYPE : flags 132 val SCREEN_FONTTYPE : flags 133 val SIMULATED_FONTTYPE : flags 134 end 135 136 type CHOOSEFONT = 137 { 138 owner: HWND option, 139 context: HDC option, 140 logFont: Font.LOGFONT option, 141 pointSize: int, 142 flags: ChooseFontFlags.flags, 143 colors: COLORREF, 144 style: string option, 145 fontType: ChooseFontTypes.flags, 146 size: {min: int, max: int} option 147 } 148 149 val ChooseFont : CHOOSEFONT -> CHOOSEFONT option 150 *) 151 152 (* FindText and ReplaceText *) 153 structure FindReplaceFlags : 154 sig 155 include BIT_FLAGS 156 val FR_DIALOGTERM : flags 157 val FR_DOWN : flags 158 val FR_FINDNEXT : flags 159 val FR_HIDEMATCHCASE : flags 160 val FR_HIDEUPDOWN : flags 161 val FR_HIDEWHOLEWORD : flags 162 val FR_MATCHCASE : flags 163 val FR_NOMATCHCASE : flags 164 val FR_NOUPDOWN : flags 165 val FR_NOWHOLEWORD : flags 166 val FR_REPLACE : flags 167 val FR_REPLACEALL : flags 168 val FR_SHOWHELP : flags 169 val FR_WHOLEWORD : flags 170 end 171 172 datatype 173 TemplateType = 174 TemplateDefault 175 | TemplateHandle of Dialog.DLGTEMPLATE 176 | TemplateResource of HINSTANCE * Resource.RESID 177 178 type FINDREPLACE = 179 { 180 owner : HWND, 181 template: TemplateType, 182 flags: FindReplaceFlags.flags, 183 findWhat: string, 184 replaceWith: string, 185 bufferSize: int 186 } 187 188 val FindText : FINDREPLACE -> HWND 189 val ReplaceText : FINDREPLACE -> HWND 190 191 192 (* GetOpenFileName and GetSaveFileName *) 193 194 structure OpenFileFlags : 195 sig 196 include BIT_FLAGS 197 val OFN_ALLOWMULTISELECT : flags 198 val OFN_CREATEPROMPT : flags 199 val OFN_EXPLORER : flags 200 val OFN_EXTENSIONDIFFERENT : flags 201 val OFN_FILEMUSTEXIST : flags 202 val OFN_HIDEREADONLY : flags 203 val OFN_LONGNAMES : flags 204 val OFN_NOCHANGEDIR : flags 205 val OFN_NODEREFERENCELINKS : flags 206 val OFN_NOLONGNAMES : flags 207 val OFN_NONETWORKBUTTON : flags 208 val OFN_NOREADONLYRETURN : flags 209 val OFN_NOTESTFILECREATE : flags 210 val OFN_NOVALIDATE : flags 211 val OFN_OVERWRITEPROMPT : flags 212 val OFN_PATHMUSTEXIST : flags 213 val OFN_READONLY : flags 214 val OFN_SHAREAWARE : flags 215 val OFN_SHOWHELP : flags 216 end 217 218 type OPENFILENAME = 219 { 220 owner: HWND option, 221 template: TemplateType, 222 filter: (string * string) list, 223 customFilter: (string * string) option, 224 filterIndex: int, 225 file: string, (* Initial value of file and returned result. *) 226 maxFile: int, (* Max size of expected file name. *) 227 fileTitle : string, 228 initialDir: string option, 229 title: string option, (* Optional title - default is Save or Open. *) 230 flags: OpenFileFlags.flags, 231 defExt: string option 232 } 233 234 val GetFileTitle : string -> string 235 val GetOpenFileName : OPENFILENAME -> OPENFILENAME option 236 val GetSaveFileName : OPENFILENAME -> OPENFILENAME option 237 238 (* PageSetupDlg *) 239 structure PageSetupFlags : 240 sig 241 include BIT_FLAGS 242 val PSD_DEFAULTMINMARGINS : flags 243 val PSD_DISABLEMARGINS : flags 244 val PSD_DISABLEORIENTATION : flags 245 val PSD_DISABLEPAGEPAINTING : flags 246 val PSD_DISABLEPAPER : flags 247 val PSD_DISABLEPRINTER : flags 248 val PSD_INHUNDREDTHSOFMILLIMETERS : flags 249 val PSD_INTHOUSANDTHSOFINCHES : flags 250 val PSD_MARGINS : flags 251 val PSD_MINMARGINS : flags 252 val PSD_NONETWORKBUTTON : flags 253 val PSD_NOWARNING : flags 254 val PSD_RETURNDEFAULT : flags 255 val PSD_SHOWHELP : flags 256 end 257 258 type PAGESETUPDLG = 259 { 260 owner: HWND option, 261 devMode: DeviceContext.DEVMODE option, 262 devNames: DeviceContext.DEVNAMES option, 263 flags: PageSetupFlags.flags, 264 paperSize: POINT, 265 minMargin: RECT, 266 margin: RECT 267 (* For the moment we ignore the other options. *) 268 } 269 270 val PageSetupDlg : PAGESETUPDLG -> PAGESETUPDLG option 271 272 (* PrintDlg *) 273 structure PrintDlgFlags : 274 sig 275 include BIT_FLAGS 276 val PD_ALLPAGES : flags 277 val PD_COLLATE : flags 278 val PD_DISABLEPRINTTOFILE : flags 279 val PD_HIDEPRINTTOFILE : flags 280 val PD_NONETWORKBUTTON : flags 281 val PD_NOPAGENUMS : flags 282 val PD_NOSELECTION : flags 283 val PD_NOWARNING : flags 284 val PD_PAGENUMS : flags 285 val PD_PRINTSETUP : flags 286 val PD_PRINTTOFILE : flags 287 val PD_RETURNDC : flags 288 val PD_RETURNDEFAULT : flags 289 val PD_RETURNIC : flags 290 val PD_SELECTION : flags 291 val PD_SHOWHELP : flags 292 val PD_USEDEVMODECOPIES : flags 293 val PD_USEDEVMODECOPIESANDCOLLATE : flags 294 end 295 296 type PRINTDLG = 297 { 298 owner: HWND option, 299 devMode: DeviceContext.DEVMODE option, 300 devNames: DeviceContext.DEVNAMES option, 301 context: HDC option, 302 flags: PrintDlgFlags.flags, 303 fromPage: int, 304 toPage: int, 305 minPage: int, 306 maxPage: int, 307 copies: int 308 (* For the moment we ignore the other options. *) 309 } 310 311 val PrintDlg : PRINTDLG -> PRINTDLG option 312 end 313 = 314struct 315 local 316 open Foreign 317 open Globals 318 open Base 319 open DeviceContext Color Font GdiBase 320 321 val stringToBuf = copyStringToMem 322 323 fun allocAndInitialise(space: int, str: string) = 324 let 325 open Memory 326 val space = Int.max(space, size str) + 1 327 val buf = malloc(Word.fromInt space) 328 in 329 stringToBuf(buf, 0, str); 330 buf 331 end 332 333 in 334 type HWND = HWND and HDC = HDC and COLORREF = COLORREF and HINSTANCE = HINSTANCE 335 type RECT = RECT and POINT = POINT 336 337 datatype CDERR = 338 DIALOGFAILURE (* 0xffff *) 339 | GENERALCODES (* 0x0000 *) 340 | STRUCTSIZE (* 0x0001 *) 341 | INITIALIZATION (* 0x0002 *) 342 | NOTEMPLATE (* 0x0003 *) 343 | NOHINSTANCE (* 0x0004 *) 344 | LOADSTRFAILURE (* 0x0005 *) 345 | FINDRESFAILURE (* 0x0006 *) 346 | LOADRESFAILURE (* 0x0007 *) 347 | LOCKRESFAILURE (* 0x0008 *) 348 | MEMALLOCFAILURE (* 0x0009 *) 349 | MEMLOCKFAILURE (* 0x000A *) 350 | NOHOOK (* 0x000B *) 351 | REGISTERMSGFAIL (* 0x000C *) 352 353 | PRINTERCODES (* 0x1000 *) 354 | SETUPFAILURE (* 0x1001 *) 355 | PARSEFAILURE (* 0x1002 *) 356 | RETDEFFAILURE (* 0x1003 *) 357 | LOADDRVFAILURE (* 0x1004 *) 358 | GETDEVMODEFAIL (* 0x1005 *) 359 | INITFAILURE (* 0x1006 *) 360 | NODEVICES (* 0x1007 *) 361 | NODEFAULTPRN (* 0x1008 *) 362 | DNDMMISMATCH (* 0x1009 *) 363 | CREATEICFAILURE (* 0x100A *) 364 | PRINTERNOTFOUND (* 0x100B *) 365 | DEFAULTDIFFERENT (* 0x100C *) 366 367 | CHOOSEFONTCODES (* 0x2000 *) 368 | NOFONTS (* 0x2001 *) 369 | MAXLESSTHANMIN (* 0x2002 *) 370 371 | FILENAMECODES (* 0x3000 *) 372 | SUBCLASSFAILURE (* 0x3001 *) 373 | INVALIDFILENAME (* 0x3002 *) 374 | BUFFERTOOSMALL (* 0x3003 *) 375 376 | FINDREPLACECODES (* 0x4000 *) 377 | BUFFERLENGTHZERO (* 0x4001 *) 378 379 | CHOOSECOLORCODES (* 0x5000 *) 380 381 382 local 383 val commDlgExtendedError = winCall0 (commdlg "CommDlgExtendedError") () cDWORD 384 in 385 fun CommDlgExtendedError () = 386 case commDlgExtendedError () of 387 0x0000 => GENERALCODES 388 | 0x0001 => STRUCTSIZE 389 390 | 0x0002 => INITIALIZATION 391 | 0x0003 => NOTEMPLATE 392 | 0x0004 => NOHINSTANCE 393 | 0x0005 => LOADSTRFAILURE 394 | 0x0006 => FINDRESFAILURE 395 | 0x0007 => LOADRESFAILURE 396 | 0x0008 => LOCKRESFAILURE 397 | 0x0009 => MEMALLOCFAILURE 398 | 0x000A => MEMLOCKFAILURE 399 | 0x000B => NOHOOK 400 | 0x000C => REGISTERMSGFAIL 401 402 | 0x1000 => PRINTERCODES 403 | 0x1001 => SETUPFAILURE 404 | 0x1002 => PARSEFAILURE 405 | 0x1003 => RETDEFFAILURE 406 | 0x1004 => LOADDRVFAILURE 407 | 0x1005 => GETDEVMODEFAIL 408 | 0x1006 => INITFAILURE 409 | 0x1007 => NODEVICES 410 | 0x1008 => NODEFAULTPRN 411 | 0x1009 => DNDMMISMATCH 412 | 0x100A => CREATEICFAILURE 413 | 0x100B => PRINTERNOTFOUND 414 | 0x100C => DEFAULTDIFFERENT 415 416 | 0x2000 => CHOOSEFONTCODES 417 | 0x2001 => NOFONTS 418 | 0x2002 => MAXLESSTHANMIN 419 420 | 0x3000 => FILENAMECODES 421 | 0x3001 => SUBCLASSFAILURE 422 | 0x3002 => INVALIDFILENAME 423 | 0x3003 => BUFFERTOOSMALL 424 425 | 0x4000 => FINDREPLACECODES 426 | 0x4001 => BUFFERLENGTHZERO 427 | _ => DIALOGFAILURE 428 end; 429 430 (* As always there are a number of ways of matching the C types to 431 ML. Since functions such as GetOpenFileName update their 432 parameters, probably the easiest way to deal with them is 433 as functions which return an updated parameter set. *) 434 datatype TemplateType = 435 TemplateHandle of Dialog.DLGTEMPLATE 436 | TemplateResource of HINSTANCE * Resource.RESID 437 | TemplateDefault 438 439 structure OpenFileFlags:> 440 sig 441 include BIT_FLAGS 442 val OFN_ALLOWMULTISELECT : flags 443 val OFN_CREATEPROMPT : flags 444 val OFN_EXPLORER : flags 445 val OFN_EXTENSIONDIFFERENT : flags 446 val OFN_FILEMUSTEXIST : flags 447 val OFN_HIDEREADONLY : flags 448 val OFN_LONGNAMES : flags 449 val OFN_NOCHANGEDIR : flags 450 val OFN_NODEREFERENCELINKS : flags 451 val OFN_NOLONGNAMES : flags 452 val OFN_NONETWORKBUTTON : flags 453 val OFN_NOREADONLYRETURN : flags 454 val OFN_NOTESTFILECREATE : flags 455 val OFN_NOVALIDATE : flags 456 val OFN_OVERWRITEPROMPT : flags 457 val OFN_PATHMUSTEXIST : flags 458 val OFN_READONLY : flags 459 val OFN_SHAREAWARE : flags 460 val OFN_SHOWHELP : flags 461 462 val cConvert: flags conversion 463 end 464 = 465 struct 466 open Word32 467 type flags = word 468 val toWord = toLargeWord 469 and fromWord = fromLargeWord 470 val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 471 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 472 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 473 fun clear (fl1, fl2) = andb(notb fl1, fl2) 474 475 val OFN_READONLY = 0wx00000001 476 val OFN_OVERWRITEPROMPT = 0wx00000002 477 val OFN_HIDEREADONLY = 0wx00000004 478 val OFN_NOCHANGEDIR = 0wx00000008 479 val OFN_SHOWHELP = 0wx00000010 480 val OFN_NOVALIDATE = 0wx00000100 481 val OFN_ALLOWMULTISELECT = 0wx00000200 482 val OFN_EXTENSIONDIFFERENT = 0wx00000400 483 val OFN_PATHMUSTEXIST = 0wx00000800 484 val OFN_FILEMUSTEXIST = 0wx00001000 485 val OFN_CREATEPROMPT = 0wx00002000 486 val OFN_SHAREAWARE = 0wx00004000 487 val OFN_NOREADONLYRETURN = 0wx00008000 488 val OFN_NOTESTFILECREATE = 0wx00010000 489 val OFN_NONETWORKBUTTON = 0wx00020000 490 val OFN_NOLONGNAMES = 0wx00040000 (* force no long names for 4.x modules*) 491 val OFN_EXPLORER = 0wx00080000 (* new look commdlg*) 492 val OFN_NODEREFERENCELINKS = 0wx00100000 493 val OFN_LONGNAMES = 0wx00200000 (* force long names for 3.x modules*) 494 495 val all = flags[OFN_READONLY, OFN_OVERWRITEPROMPT, OFN_HIDEREADONLY, 496 OFN_NOCHANGEDIR, OFN_SHOWHELP, 497 OFN_NOVALIDATE, OFN_ALLOWMULTISELECT, OFN_EXTENSIONDIFFERENT, 498 OFN_PATHMUSTEXIST, OFN_FILEMUSTEXIST, OFN_CREATEPROMPT, 499 OFN_SHAREAWARE, OFN_NOREADONLYRETURN, OFN_NOTESTFILECREATE, 500 OFN_NONETWORKBUTTON, OFN_NOLONGNAMES, OFN_EXPLORER, 501 OFN_NODEREFERENCELINKS, OFN_LONGNAMES] 502 503 val intersect = List.foldl (fn (a, b) => andb(a,b)) all 504 505 val cConvert = cDWORDw 506 end 507 508 (* These flags are local only. *) 509 (*val OFN_ENABLEHOOK = OpenFileFlags.fromWord 0wx00000020 *) 510 val OFN_ENABLETEMPLATE = OpenFileFlags.fromWord 0wx00000040 511 val OFN_ENABLETEMPLATEHANDLE = OpenFileFlags.fromWord 0wx00000080 512 513 type OPENFILENAME = 514 { 515 owner: HWND option, 516 template: TemplateType, 517 filter: (string * string) list, 518 customFilter: (string * string) option, 519 filterIndex: int, 520 file: string, (* Initial value of file and returned result. *) 521 maxFile: int, (* Max size of expected file name. *) 522 fileTitle : string, 523 initialDir: string option, 524 title: string option, (* Optional title - default is Save or Open. *) 525 flags: OpenFileFlags.flags, 526 defExt: string option 527 } 528 529 local 530 val OPENFILENAME = 531 cStruct20(cDWORD, cHWNDOPT, cPointer (*HINSTANCE*), cPointer (* LPCTSTR*), cPointer (*LPTSTR*), 532 cDWORD, cDWORD, cPointer (*LPTSTR*), cDWORD, cPointer (*LPTSTR*), cDWORD, STRINGOPT, STRINGOPT, 533 OpenFileFlags.cConvert, cWORD, cWORD, STRINGOPT, cLPARAM, cPointer (* LPOFNHOOKPROC *), 534 cPointer (* LPCTSTR*) (* cPointer, DWORD, DWORD*)) 535 val {load=loadOFN, store=fromOFN, ctype={size=sizeOfnStruct, ...}, ...} = breakConversion OPENFILENAME 536 537 fun getOpenSave doCall (arg: OPENFILENAME): OPENFILENAME option = 538 let 539 val { 540 owner: HWND option, 541 template: TemplateType, 542 filter: (string * string) list, 543 customFilter: (string * string) option, 544 filterIndex: int, 545 file: string, 546 maxFile: int, 547 fileTitle : string, 548 initialDir: string option, 549 title: string option, 550 flags: OpenFileFlags.flags, 551 defExt: string option, ...} = arg 552 open Memory 553 infix 6 ++ 554 val (f1, inst, templ, toFree) = 555 case template of 556 TemplateHandle dlgTemp => 557 let 558 val dlg = toCWord8vec(Dialog.compileTemplate dlgTemp) 559 in 560 (OFN_ENABLETEMPLATEHANDLE, dlg, null, dlg) 561 end 562 | TemplateResource(hInst, IdAsInt wb) => 563 ( 564 OFN_ENABLETEMPLATE, 565 voidStarOfHandle hInst, 566 Memory.sysWord2VoidStar(SysWord.fromInt wb), 567 null 568 ) 569 | TemplateResource(hInst, IdAsString str) => 570 let 571 val s = toCstring str 572 in 573 (OFN_ENABLETEMPLATE, voidStarOfHandle hInst, s, s) 574 end 575 | TemplateDefault => (OpenFileFlags.fromWord 0w0, null, null, null) 576 577 val lpstrFilter = 578 case filter of 579 nil => Memory.null 580 | _ => 581 let 582 (* The filter strings are pairs of strings with a final 583 terminating null. That implies that the strings cannot be empty. 584 Should we check that? 585 Get the store needed for the strings, including the null 586 terminations and the final null. *) 587 val filterSize = 588 List.foldl (fn((s1,s2),n) => size s1 + size s2 + n + 2) 1 filter 589 open Memory 590 infix 6 ++ 591 val buf = malloc (Word.fromInt filterSize) 592 593 fun copyToBuf((s1,s2), n) = 594 let 595 val ss1 = size s1 and ss2 = size s2 596 in 597 stringToBuf(buf, n, s1); 598 stringToBuf(buf, n+ss1+1, s2); 599 n+ss1+ss2+2 (* Result is the next offset. *) 600 end 601 602 val lastAddr = List.foldl copyToBuf 0 filter 603 val _ = set8(buf, Word.fromInt lastAddr, 0w0) 604 in 605 buf 606 end 607 608 val (lpstrCustomFilter, nMaxCustFilter) = 609 case customFilter of 610 NONE => (null, 0) 611 | SOME (dispString, pattern) => 612 let 613 (* Make sure we have enough space. 100 is probably big enough. *) 614 val space = Int.max(size dispString + size pattern + 2, 100) 615 val buf = Memory.malloc(Word.fromInt space) 616 in 617 stringToBuf(buf, 0, dispString); 618 stringToBuf(buf, size dispString + 1, pattern); 619 (buf, space) 620 end 621 622 val lpstrFile = (* Full name of file including path. *) 623 allocAndInitialise(maxFile, file) 624 val lpstrFileTitle = (* Name excluding the path. *) 625 allocAndInitialise(maxFile, fileTitle) 626 627 val ofn = malloc sizeOfnStruct 628 val args = (Word.toInt sizeOfnStruct, (* lStructSize *) 629 owner, (* hwndOwner *) 630 inst, (* hInstance *) 631 lpstrFilter, 632 lpstrCustomFilter, 633 nMaxCustFilter, 634 filterIndex, 635 lpstrFile, 636 maxFile+1, (* nMaxFile *) 637 lpstrFileTitle, 638 maxFile+1, (* nMaxFileTitle *) 639 initialDir, 640 title, 641 OpenFileFlags.flags[f1, flags], (* Flags *) 642 0, (* nFileOffset *) 643 0, (* nFileExtension *) 644 defExt, 645 0, (* lCustData *) 646 null, (* lpfnHook *) 647 templ) (* lpTemplateName *) 648 val freeOfn = fromOFN(ofn, args) (* Copy into the memory *) 649 fun freeAll() = 650 ( 651 freeOfn(); 652 List.app free [ofn, toFree, lpstrFilter, lpstrCustomFilter, lpstrFile, lpstrFileTitle] 653 ) 654 val result = 655 doCall ofn handle ex => (freeAll(); raise ex) 656 in 657 (if result 658 then 659 let 660 (* Most of the fields are unchanged so we're better off extracting 661 them from the original. If we've passed in a template we have 662 to get it from the original because we can only convert a 663 memory object to a Word8Vector.vector if we know its length. *) 664 665 val (_, _, _, _, lpstrCustomFilter, _, nFilterIndex, lpstrFile, 666 _, lpstrFileTitle, _, _, _, flagBits, _, _, _, _, _, _) = loadOFN ofn 667 668 val customFilter = 669 if lpstrCustomFilter = null 670 then NONE 671 else 672 let 673 (* The dialogue box copies the selected filter into the section of 674 this string after the first string. *) 675 val s1 = fromCstring lpstrCustomFilter 676 val s2 = fromCstring (lpstrCustomFilter ++ Word.fromInt(size s1 +1)) 677 in 678 SOME(s1, s2) 679 end 680 in 681 SOME 682 { 683 owner = owner, 684 template = template, 685 filter = filter, 686 customFilter = customFilter, 687 filterIndex = nFilterIndex, 688 file = fromCstring lpstrFile, 689 maxFile = maxFile, 690 fileTitle = fromCstring lpstrFileTitle, 691 initialDir = initialDir, 692 title = title, 693 (* Mask off the template flags. *) 694 flags = let open OpenFileFlags in clear(fromWord 0wxE0, flagBits) end, 695 defExt = defExt 696 } 697 end 698 else NONE) before freeAll() 699 end 700 701 in 702 val GetOpenFileName = 703 getOpenSave (winCall1 (commdlg "GetOpenFileNameA") cPointer cBool) 704 and GetSaveFileName = 705 getOpenSave (winCall1 (commdlg "GetSaveFileNameA") cPointer cBool) 706 end (* local *) 707 708 local 709 val getFileTitle = winCall3(commdlg "GetFileTitleA") (cString, cPointer, cWORD) cShort 710 in 711 fun GetFileTitle(file: string): string = 712 let 713 fun gft (m, n) = getFileTitle(file, m, n) 714 in 715 getStringWithNullIsLength gft 716 end 717 end 718 719 (* This is a bit messy. It creates a modeless dialogue box 720 and sends messages to the parent window. The only problem is that 721 the message identifier is not a constant. It has to be obtained 722 by a call to RegisterWindowMessage. *) 723 (* We also have to ensure that the memory containing the FINDREPLACE 724 structure is not freed until the dialogue window is destroyed. *) 725 726 structure FindReplaceFlags = FindReplaceFlags 727 728 (* These flags are local only. *) 729 (*val FR_ENABLEHOOK = FindReplaceFlags.fromWord 0wx00000100*) 730 val FR_ENABLETEMPLATE = FindReplaceFlags.fromWord 0wx00000200 731 val FR_ENABLETEMPLATEHANDLE = FindReplaceFlags.fromWord 0wx00002000 732 733 (* The address of this structure is passed in messages. That all looks 734 extremely messy. *) 735 type FINDREPLACE = 736 { 737 owner : HWND, (* NOT an option. *) 738 template: TemplateType, 739 flags: FindReplaceFlags.flags, 740 findWhat: string, 741 replaceWith: string, 742 bufferSize: int 743 } 744 745 local 746 val FINDREPLACE = 747 cStruct11(cDWORD, cHWND, cPointer (*HINSTANCE*), FindReplaceFlags.cFindReplaceFlags, 748 cPointer, cPointer, cWORD, cWORD, cLPARAM, cPointer (* LPFRHOOKPROC *), cPointer) 749 val {store=fromOFR, ctype={size=sizeFR, ...}, ...} = breakConversion FINDREPLACE 750 751 val findText = winCall1 (commdlg "FindTextA") cPointer cHWND 752 and replaceText = winCall1 (commdlg "ReplaceTextA") cPointer cHWND 753 754 fun findReplace doCall (arg: FINDREPLACE): HWND = 755 let 756 val { 757 owner : HWND, (* NOT an option. *) 758 template: TemplateType, 759 flags: FindReplaceFlags.flags, 760 findWhat: string, 761 replaceWith: string, 762 bufferSize: int 763 } = arg 764 open Memory 765 val (f1, inst, templ, toFree) = 766 case template of 767 TemplateHandle dlgTemp => 768 let 769 val dlg = toCWord8vec(Dialog.compileTemplate dlgTemp) 770 in 771 (FR_ENABLETEMPLATEHANDLE, dlg, null, dlg) 772 end 773 | TemplateResource(hInst, IdAsInt wb) => 774 ( 775 FR_ENABLETEMPLATE, 776 voidStarOfHandle hInst, 777 Memory.sysWord2VoidStar(SysWord.fromInt wb), 778 null 779 ) 780 | TemplateResource(hInst, IdAsString str) => 781 let 782 val s = toCstring str 783 in 784 (FR_ENABLETEMPLATE, voidStarOfHandle hInst, s, s) 785 end 786 | TemplateDefault => (FindReplaceFlags.fromWord 0w0, null, null, null) 787 val lpstrFindWhat = allocAndInitialise(bufferSize, findWhat) 788 val lpstrReplaceWith = allocAndInitialise(bufferSize, replaceWith) 789 val m = malloc sizeFR 790 val args = 791 (Word.toInt sizeFR, (* lStructSize *) 792 owner, (* hwndOwner *) 793 inst, (* hInstance *) 794 FindReplaceFlags.flags[f1, flags], (* Flags *) 795 lpstrFindWhat, 796 lpstrReplaceWith, 797 bufferSize, 798 bufferSize, 799 0, (* lCustData *) 800 null, (* lpfnHook *) 801 templ) (* lpTemplateName *) 802 val freeOfr = fromOFR(m, args) 803 fun freeAll() = 804 ( 805 freeOfr(); 806 List.app free [m, toFree, lpstrFindWhat, lpstrReplaceWith] 807 ) 808 val result = doCall m handle ex => (freeAll(); raise ex) 809 val () = 810 checkResult(not(isHNull result)) handle ex => (freeAll(); raise ex) 811 in 812 (* The memory cannot be released until the dialogue is dismissed. Also, 813 since this is a modeless dialogue we have to add it to the modeless 814 dialogue list so that keyboard functions work. *) 815 (* TODO: There may be better ways of ensuring the memory is freed. *) 816 (Message.addModelessDialogue(result, SOME freeAll); result) 817 end 818 in 819 val FindText = findReplace findText 820 and ReplaceText = findReplace replaceText 821 end 822 823 structure PageSetupFlags :> 824 sig 825 include BIT_FLAGS 826 val PSD_DEFAULTMINMARGINS : flags 827 val PSD_DISABLEMARGINS : flags 828 val PSD_DISABLEORIENTATION : flags 829 val PSD_DISABLEPAGEPAINTING : flags 830 val PSD_DISABLEPAPER : flags 831 val PSD_DISABLEPRINTER : flags 832 val PSD_INHUNDREDTHSOFMILLIMETERS : flags 833 val PSD_INTHOUSANDTHSOFINCHES : flags 834 val PSD_MARGINS : flags 835 val PSD_MINMARGINS : flags 836 val PSD_NONETWORKBUTTON : flags 837 val PSD_NOWARNING : flags 838 val PSD_RETURNDEFAULT : flags 839 val PSD_SHOWHELP : flags 840 val cConvert: flags conversion 841 end 842 = 843 struct 844 open Word32 845 type flags = word 846 val toWord = toLargeWord 847 and fromWord = fromLargeWord 848 val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 849 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 850 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 851 fun clear (fl1, fl2) = andb(notb fl1, fl2) 852 853 val PSD_DEFAULTMINMARGINS = 0wx00000000 (* default (printer's) *) 854 (*val PSD_INWININIINTLMEASURE = 0wx00000000 *)(* 1st of 4 possible *) 855 856 val PSD_MINMARGINS = 0wx00000001 (* use caller's *) 857 val PSD_MARGINS = 0wx00000002 (* use caller's *) 858 val PSD_INTHOUSANDTHSOFINCHES = 0wx00000004 (* 2nd of 4 possible *) 859 val PSD_INHUNDREDTHSOFMILLIMETERS = 0wx00000008 (* 3rd of 4 possible *) 860 val PSD_DISABLEMARGINS = 0wx00000010 861 val PSD_DISABLEPRINTER = 0wx00000020 862 val PSD_NOWARNING = 0wx00000080 863 val PSD_DISABLEORIENTATION = 0wx00000100 864 val PSD_RETURNDEFAULT = 0wx00000400 865 val PSD_DISABLEPAPER = 0wx00000200 866 val PSD_SHOWHELP = 0wx00000800 867 (* 868 val PSD_ENABLEPAGESETUPHOOK = 0wx00002000 869 val PSD_ENABLEPAGESETUPTEMPLATE = 0wx00008000 870 val PSD_ENABLEPAGESETUPTEMPLATEHANDLE = 0wx00020000 871 val PSD_ENABLEPAGEPAINTHOOK = 0wx00040000 *) 872 873 val PSD_DISABLEPAGEPAINTING = 0wx00080000 874 val PSD_NONETWORKBUTTON = 0wx00200000 875 876 val all = flags[PSD_DEFAULTMINMARGINS, PSD_MINMARGINS, PSD_MARGINS, 877 PSD_INTHOUSANDTHSOFINCHES, PSD_INHUNDREDTHSOFMILLIMETERS, 878 PSD_DISABLEMARGINS, PSD_DISABLEPRINTER, PSD_NOWARNING, 879 PSD_DISABLEORIENTATION, PSD_RETURNDEFAULT, PSD_DISABLEPAPER, 880 PSD_SHOWHELP, PSD_DISABLEPAGEPAINTING, PSD_NONETWORKBUTTON] 881 882 val intersect = List.foldl (fn (a, b) => andb(a,b)) all 883 884 val cConvert = cDWORDw 885 end 886 887 structure PrintDlgFlags :> 888 sig 889 include BIT_FLAGS 890 val PD_ALLPAGES : flags 891 val PD_COLLATE : flags 892 val PD_DISABLEPRINTTOFILE : flags 893 val PD_HIDEPRINTTOFILE : flags 894 val PD_NONETWORKBUTTON : flags 895 val PD_NOPAGENUMS : flags 896 val PD_NOSELECTION : flags 897 val PD_NOWARNING : flags 898 val PD_PAGENUMS : flags 899 val PD_PRINTSETUP : flags 900 val PD_PRINTTOFILE : flags 901 val PD_RETURNDC : flags 902 val PD_RETURNDEFAULT : flags 903 val PD_RETURNIC : flags 904 val PD_SELECTION : flags 905 val PD_SHOWHELP : flags 906 val PD_USEDEVMODECOPIES : flags 907 val PD_USEDEVMODECOPIESANDCOLLATE : flags 908 val cConvert: flags conversion 909 end 910 = 911 struct 912 open Word32 913 type flags = word 914 val toWord = toLargeWord 915 and fromWord = fromLargeWord 916 val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 917 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 918 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 919 fun clear (fl1, fl2) = andb(notb fl1, fl2) 920 921 val PD_ALLPAGES = 0wx00000000 922 val PD_SELECTION = 0wx00000001 923 val PD_PAGENUMS = 0wx00000002 924 val PD_NOSELECTION = 0wx00000004 925 val PD_NOPAGENUMS = 0wx00000008 926 val PD_COLLATE = 0wx00000010 927 val PD_PRINTTOFILE = 0wx00000020 928 val PD_PRINTSETUP = 0wx00000040 929 val PD_NOWARNING = 0wx00000080 930 val PD_RETURNDC = 0wx00000100 931 val PD_RETURNIC = 0wx00000200 932 val PD_RETURNDEFAULT = 0wx00000400 933 val PD_SHOWHELP = 0wx00000800 934 (*val PD_ENABLEPRINTHOOK = 0wx00001000 935 val PD_ENABLESETUPHOOK = 0wx00002000 936 val PD_ENABLEPRINTTEMPLATE = 0wx00004000 937 val PD_ENABLESETUPTEMPLATE = 0wx00008000 938 val PD_ENABLEPRINTTEMPLATEHANDLE = 0wx00010000 939 val PD_ENABLESETUPTEMPLATEHANDLE = 0wx00020000 *) 940 val PD_USEDEVMODECOPIES = 0wx00040000 941 val PD_USEDEVMODECOPIESANDCOLLATE = 0wx00040000 942 val PD_DISABLEPRINTTOFILE = 0wx00080000 943 val PD_HIDEPRINTTOFILE = 0wx00100000 944 val PD_NONETWORKBUTTON = 0wx00200000 945 946 947 val all = flags[PD_ALLPAGES, PD_SELECTION, PD_PAGENUMS, PD_NOSELECTION, PD_NOPAGENUMS, 948 PD_COLLATE, PD_PRINTTOFILE, PD_PRINTSETUP, PD_NOWARNING, PD_RETURNDC, 949 PD_RETURNIC, PD_RETURNDEFAULT, PD_SHOWHELP, PD_USEDEVMODECOPIES, 950 PD_USEDEVMODECOPIESANDCOLLATE, PD_DISABLEPRINTTOFILE, 951 PD_HIDEPRINTTOFILE, PD_NONETWORKBUTTON] 952 953 val intersect = List.foldl (fn (a, b) => andb(a,b)) all 954 955 val cConvert = cDWORDw 956 end 957 958 type PAGESETUPDLG = 959 { 960 owner: HWND option, 961 devMode: DEVMODE option, 962 devNames: DEVNAMES option, 963 flags: PageSetupFlags.flags, 964 paperSize: POINT, 965 minMargin: RECT, 966 margin: RECT 967 (* For the moment we ignore the other options. *) 968 } 969 970 type PRINTDLG = 971 { 972 owner: HWND option, 973 devMode: DEVMODE option, 974 devNames: DEVNAMES option, 975 context: HDC option, 976 flags: PrintDlgFlags.flags, 977 fromPage: int, 978 toPage: int, 979 minPage: int, 980 maxPage: int, 981 copies: int 982 (* For the moment we ignore the other options. *) 983 } 984 985 local 986 (* A DEVNAMES structure is a structure containing offsets followed by 987 the actual strings. *) 988 val DEVNAMES = cStruct4(cWORD, cWORD, cWORD, cWORD) 989 val {load=toDN, store=fromDN, ctype={size=sizeDevN, ...}, ...} = breakConversion DEVNAMES 990 val DN_DEFAULTPRN = 0x0001 991 992 (* Allocate global memory for the devnames if necessary *) 993 fun toDevNames NONE = hNull 994 | toDevNames (SOME{driver, device, output, default}) = 995 let 996 (* We need memory for the DEVNAMES structure plus the strings plus 997 their terminating nulls. *) 998 val devnameSize = Word.toInt sizeDevN 999 val sizeDriver = size driver 1000 and sizeDevice = size device 1001 and sizeOutput = size output 1002 val space = devnameSize + sizeDriver + sizeDevice + sizeOutput + 3 1003 val mHandle = GlobalAlloc(0, space) 1004 val buff = GlobalLock mHandle 1005 (* Copy in the strings and calculate the next offset. *) 1006 open Memory 1007 infix 6 ++ 1008 fun copyString b str = 1009 ( 1010 stringToBuf(b, 0, str); 1011 b ++ Word.fromInt(size str+1) 1012 ); 1013 val off1 = copyString (buff ++ sizeDevN) driver; 1014 val off2 = copyString off1 device 1015 val _ = copyString off2 output 1016 in 1017 ignore(fromDN(buff, (devnameSize, devnameSize+sizeDriver+1, 1018 devnameSize+sizeDriver+sizeDevice+2, 1019 if default then DN_DEFAULTPRN else 0))); 1020 GlobalUnlock mHandle; 1021 mHandle 1022 end 1023 1024 (* Convert a DevNames structure. *) 1025 fun fromDevNames v = 1026 if isHNull v then NONE 1027 else 1028 let 1029 val buff = GlobalLock v 1030 val (off0, off1, off2, def) = toDN buff 1031 open Memory 1032 infix 6 ++ 1033 val driver = fromCstring(buff ++ Word.fromInt off0) 1034 val device = fromCstring(buff ++ Word.fromInt off1) 1035 val output = fromCstring(buff ++ Word.fromInt off2) 1036 val default = IntInf.andb(def, DN_DEFAULTPRN) <> 0 1037 in 1038 GlobalUnlock v; 1039 SOME {driver=driver, device=device, output=output, default=default} 1040 end 1041 1042 val PAGESETUPDLG = 1043 cStruct14(cDWORD, cHWNDOPT, cHGLOBAL, cHGLOBAL, PageSetupFlags.cConvert, cPoint, 1044 cRect, cRect, cHINSTANCE, cLPARAM, cPointer, cPointer, cPointer, cPointer) 1045 val {load=toPSD, store=fromPSD, ctype={size=sizePageSD, ...}, ...} = breakConversion PAGESETUPDLG 1046 1047 (* This is a bit of a mess. It seems that it uses structure packing on 32-bits 1048 which means that the fields after the five shorts are not aligned onto 1049 4-byte boundaries. We currently don't use them so we just define this as 1050 the structure as far as we use it and set the length explicitly. 1051 This problem doesn't arise with PrintDlgEx so that might be preferable. *) 1052 val PRINTDLG = cStruct11(cDWORD, cHWNDOPT, cHGLOBAL, cHGLOBAL, cHDC, PrintDlgFlags.cConvert, cWORD, 1053 cWORD, cWORD, cWORD, cWORD) 1054 val {load=toPRD, store=fromPRD, ...} = breakConversion PRINTDLG 1055 val printDlgSize = 1056 if #size LowLevel.cTypePointer = 0w4 then 0w66 else 0w120 1057 1058 val pageSetupDlg = winCall1 (commdlg "PageSetupDlgA") cPointer cBool 1059 and printDlg = winCall1 (commdlg "PrintDlgA") cPointer cBool 1060 in 1061 fun PageSetupDlg (arg: PAGESETUPDLG): PAGESETUPDLG option = 1062 let 1063 val { 1064 owner: HWND option, 1065 devMode: DEVMODE option, 1066 devNames: {driver: string, device: string, output: string, default: bool} option, 1067 flags: PageSetupFlags.flags, 1068 paperSize: POINT, 1069 minMargin: RECT, 1070 margin: RECT} = arg 1071 val devnames = toDevNames devNames 1072 val devmode = 1073 case devMode of 1074 NONE => hNull 1075 | SOME dv => 1076 let 1077 (* This has to be in global memory *) 1078 open DeviceBase 1079 val hGlob = GlobalAlloc(0, Word.toInt(devModeSize dv)) 1080 val mem = GlobalLock hGlob 1081 val () = setCDevMode(mem, dv) 1082 in 1083 GlobalUnlock hGlob; 1084 hGlob 1085 end 1086 open Memory 1087 val mem = malloc sizePageSD 1088 val str = (Word.toInt sizePageSD, owner, devmode, devnames, flags, 1089 paperSize, minMargin, margin, hinstanceNull, 0, null, null, null, null) 1090 val freePsd = fromPSD(mem, str) (* Set the PAGESETUPDLG struct *) 1091 1092 fun freeAll() = 1093 let 1094 (* We can only free the handles after we've reloaded them. *) 1095 val (_, _, hgDevMode, hgDevNames, _, _, _, _, _, _, _, _, _, _) = toPSD mem 1096 in 1097 if isHNull hgDevNames then () else ignore(GlobalFree hgDevNames); 1098 if isHNull hgDevMode then () else ignore(GlobalFree hgDevMode); 1099 free mem; freePsd() 1100 end 1101 1102 val result = pageSetupDlg mem handle ex => (freeAll(); raise ex) 1103 val (_, owner, hgDevMode, hgDevNames, flags, paperSize, minMargin, margin, 1104 _, _, _, _, _, _) = toPSD mem 1105 val devMode = 1106 if isHNull hgDevMode 1107 then NONE 1108 else 1109 let 1110 val r = SOME(DeviceBase.getCDevMode(GlobalLock hgDevMode)) 1111 in 1112 GlobalUnlock hgDevMode; 1113 r 1114 end; 1115 val devNames = fromDevNames hgDevNames 1116 val newArg = 1117 { owner = owner, devMode = devMode, devNames = devNames, 1118 flags = flags, 1119 paperSize = paperSize, minMargin = minMargin, margin = margin } 1120 val () = freeAll() 1121 in 1122 if result 1123 then SOME newArg 1124 else NONE 1125 end 1126 1127 and PrintDlg (arg: PRINTDLG): PRINTDLG option = 1128 let 1129 val { 1130 owner: HWND option, 1131 devMode: DEVMODE option, 1132 devNames: {driver: string, device: string, output: string, default: bool} option, 1133 context: HDC option, 1134 flags: PrintDlgFlags.flags, 1135 fromPage: int, 1136 toPage: int, 1137 minPage: int, 1138 maxPage: int, 1139 copies: int} = arg 1140 val devnames = toDevNames devNames 1141 val devmode = 1142 case devMode of 1143 NONE => hNull 1144 | SOME dv => 1145 let 1146 (* This has to be in global memory *) 1147 open DeviceBase 1148 val hGlob = GlobalAlloc(0, Word.toInt(devModeSize dv)) 1149 val mem = GlobalLock hGlob 1150 val () = setCDevMode(mem, dv) 1151 in 1152 GlobalUnlock hGlob; 1153 hGlob 1154 end 1155 open Memory 1156 val mem = malloc printDlgSize 1157 (* Since we're not going to set all of it we need to zero it. *) 1158 local 1159 fun zero n = if n = printDlgSize then () else (set8(mem, n, 0w0); zero(n+0w1)) 1160 in 1161 val () = zero 0w0 1162 end 1163 val freePRD = 1164 fromPRD(mem, (Word.toInt printDlgSize, owner, devmode, devnames, getOpt(context, hdcNull), 1165 flags, fromPage, toPage, minPage, maxPage, copies)) 1166 1167 fun freeAll() = 1168 let 1169 (* We can only free the handles after we've reloaded them. *) 1170 val (_, _, hgDevMode, hgDevNames, _, _, _, _, _, _, _) = toPRD mem 1171 in 1172 if isHNull hgDevNames then () else ignore(GlobalFree hgDevNames); 1173 if isHNull hgDevMode then () else ignore(GlobalFree hgDevMode); 1174 free mem; freePRD() 1175 end 1176 1177 val result = printDlg mem handle ex => (freeAll(); raise ex) 1178 (* Convert the result. We have to do this even if the result is 1179 false to make sure we call GlobalFree on any global handles. *) 1180 val (_, owner, hgDevMode, hgDevNames, hdc, flags, fromPage, toPage, minPage, 1181 maxPage, copies) = toPRD mem 1182 val devMode = 1183 if isHNull hgDevMode 1184 then NONE 1185 else 1186 let 1187 val r = SOME(DeviceBase.getCDevMode(GlobalLock hgDevMode)) 1188 in 1189 GlobalUnlock hgDevMode; 1190 r 1191 end; 1192 val devNames = fromDevNames hgDevNames 1193 val newArg = 1194 { owner = owner, devMode = devMode, devNames = devNames, 1195 context = if isHdcNull hdc then NONE else SOME hdc, 1196 flags = flags, fromPage = fromPage, toPage = toPage, 1197 minPage = minPage, maxPage = maxPage, copies = copies } 1198 val () = freeAll() 1199 in 1200 if result 1201 then SOME newArg 1202 else NONE 1203 end 1204 end 1205(* 1206 structure ChooseFontFlags :> 1207 sig 1208 include BIT_FLAGS 1209 val CF_ANSIONLY : flags 1210 val CF_APPLY : flags 1211 val CF_BOTH : flags 1212 val CF_EFFECTS : flags 1213 val CF_FIXEDPITCHONLY : flags 1214 val CF_FORCEFONTEXIST : flags 1215 val CF_NOFACESEL : flags 1216 val CF_NOOEMFONTS : flags 1217 val CF_NOSCRIPTSEL : flags 1218 val CF_NOSIMULATIONS : flags 1219 val CF_NOSIZESEL : flags 1220 val CF_NOSTYLESEL : flags 1221 val CF_NOVECTORFONTS : flags 1222 val CF_NOVERTFONTS : flags 1223 val CF_PRINTERFONTS : flags 1224 val CF_SCALABLEONLY : flags 1225 val CF_SCREENFONTS : flags 1226 val CF_SCRIPTSONLY : flags 1227 val CF_SELECTSCRIPT : flags 1228 val CF_SHOWHELP : flags 1229 val CF_TTONLY : flags 1230 val CF_WYSIWYG : flags 1231 end 1232 = 1233 struct 1234 type flags = SysWord.word 1235 fun toWord f = f 1236 fun fromWord f = f 1237 val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 1238 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 1239 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 1240 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) 1241 1242 val CF_SCREENFONTS = 0wx00000001 1243 val CF_PRINTERFONTS = 0wx00000002 1244 val CF_BOTH = 0wx00000003: flags 1245 val CF_SHOWHELP = 0wx00000004 1246 (* 1247 val CF_ENABLEHOOK = 0wx00000008 1248 val CF_ENABLETEMPLATE = 0wx00000010 1249 val CF_ENABLETEMPLATEHANDLE = 0wx00000020 1250 *) 1251 (*val CF_INITTOLOGFONTSTRUCT = 0wx00000040*) 1252 (*val CF_USESTYLE = 0wx00000080*) 1253 val CF_EFFECTS = 0wx00000100 1254 val CF_APPLY = 0wx00000200 1255 val CF_ANSIONLY = 0wx00000400 1256 val CF_SCRIPTSONLY = CF_ANSIONLY 1257 val CF_NOVECTORFONTS = 0wx00000800 1258 val CF_NOOEMFONTS = CF_NOVECTORFONTS 1259 val CF_NOSIMULATIONS = 0wx00001000 1260 (*val CF_LIMITSIZE = 0wx00002000*) 1261 val CF_FIXEDPITCHONLY = 0wx00004000 1262 val CF_WYSIWYG = 0wx00008000 1263 val CF_FORCEFONTEXIST = 0wx00010000 1264 val CF_SCALABLEONLY = 0wx00020000 1265 val CF_TTONLY = 0wx00040000 1266 val CF_NOFACESEL = 0wx00080000 1267 val CF_NOSTYLESEL = 0wx00100000 1268 val CF_NOSIZESEL = 0wx00200000 1269 val CF_SELECTSCRIPT = 0wx00400000 1270 val CF_NOSCRIPTSEL = 0wx00800000 1271 val CF_NOVERTFONTS = 0wx01000000 1272 1273 val all = flags[CF_SCREENFONTS, CF_PRINTERFONTS, CF_SHOWHELP, 1274 CF_EFFECTS, CF_APPLY, CF_ANSIONLY, CF_NOVECTORFONTS, 1275 CF_NOSIMULATIONS, CF_FIXEDPITCHONLY, CF_WYSIWYG, CF_FORCEFONTEXIST, 1276 CF_SCALABLEONLY, CF_TTONLY, CF_NOFACESEL, CF_NOSTYLESEL, CF_NOSIZESEL, 1277 CF_SELECTSCRIPT, CF_NOSCRIPTSEL, CF_NOVERTFONTS] 1278 1279 val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all 1280 end 1281 1282 structure ChooseFontTypes :> 1283 sig 1284 include BIT_FLAGS 1285 val BOLD_FONTTYPE : flags 1286 val ITALIC_FONTTYPE : flags 1287 val PRINTER_FONTTYPE : flags 1288 val REGULAR_FONTTYPE : flags 1289 val SCREEN_FONTTYPE : flags 1290 val SIMULATED_FONTTYPE : flags 1291 end 1292 = 1293 struct 1294 type flags = SysWord.word 1295 fun toWord f = f 1296 fun fromWord f = f 1297 val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 1298 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 1299 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 1300 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) 1301 1302 val SIMULATED_FONTTYPE = 0wx8000 1303 val PRINTER_FONTTYPE = 0wx4000 1304 val SCREEN_FONTTYPE = 0wx2000 1305 val BOLD_FONTTYPE = 0wx0100 1306 val ITALIC_FONTTYPE = 0wx0200 1307 val REGULAR_FONTTYPE = 0wx0400 1308 1309 val all = flags[SIMULATED_FONTTYPE, PRINTER_FONTTYPE, SCREEN_FONTTYPE, 1310 BOLD_FONTTYPE, ITALIC_FONTTYPE, REGULAR_FONTTYPE] 1311 1312 val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all 1313 end 1314 1315 type CHOOSEFONT = { 1316 owner: HWND option, 1317 context: HDC option, 1318 logFont: LOGFONT option, 1319 pointSize: int, 1320 flags: ChooseFontFlags.flags, 1321 colors: COLORREF, 1322 style: string option, 1323 fontType: ChooseFontTypes.flags, 1324 size: {min: int, max: int} option 1325 } 1326 1327 local 1328 val CHOOSEFONT = cStruct16(UINT, HWNDOPT, HDC, POINTER, INT, WORD, COLORREF, 1329 INT, INT, INT, INT, POINTER, SHORT, SHORT, INT, INT) 1330 val (toCF, fromCF, cfStruct) = breakConversion CHOOSEFONT 1331 val (toLF, fromLF, lfStruct) = breakConversion FontBase.LOGFONT 1332 val CF_LIMITSIZE = 0wx00002000 1333 val CF_INITTOLOGFONTSTRUCT = 0wx00000040 1334 val CF_USESTYLE = 0wx00000080 1335 1336 fun toCChooseFont({ 1337 owner: HWND option, 1338 context: HDC option, 1339 logFont: LOGFONT option, 1340 pointSize: int, 1341 flags: ChooseFontFlags.flags, 1342 colors: COLORREF, 1343 style: string option, 1344 fontType: ChooseFontTypes.flags, 1345 size: {min: int, max: int} option 1346 }) = 1347 let 1348 (* Use the supplied logFont otherwise allocate store for a new one. *) 1349 val logf = 1350 case logFont of 1351 SOME logf => address(fromLF logf) 1352 | NONE => address(alloc 1 lfStruct) 1353 (* Copy any style to the buffer - I don't know why this is 64. *) 1354 val lpszStyle = allocAndInitialise(64, getOpt(style, "")) 1355 val (min, max) = case size of SOME {min, max} => (min, max) | NONE => (0,0) 1356 val f1 = case size of SOME _ => CF_LIMITSIZE | _ => 0w0 1357 val f2 = case logFont of SOME _ => CF_INITTOLOGFONTSTRUCT | _ => 0w0 1358 val f3 = case style of SOME _ => CF_USESTYLE | _ => 0w0 1359 val flags = List.foldl LargeWord.orb 0w0 [ChooseFontFlags.toWord flags, f1, f2, f3] 1360 in 1361 address( 1362 fromCF(sizeof cfStruct, owner, getOpt(context, hdcNull), logf, pointSize, 1363 flags, colors, 0, 0, 0, 0, lpszStyle, 1364 LargeWord.toInt (ChooseFontTypes.toWord fontType), 0, min, max)) 1365 end 1366 1367 fun fromCChooseFont v : CHOOSEFONT = 1368 let 1369 val (_, owner, hdc, logf, pointSize, flags, colors, _, _, _, _, style, 1370 types, _, min, max) = toCF(deref v) 1371 val minMax = 1372 if LargeWord.andb(flags, CF_LIMITSIZE) = 0w0 1373 then NONE 1374 else SOME{min=min, max=max} 1375 val style = 1376 if LargeWord.andb(flags, CF_USESTYLE) = 0w0 1377 then NONE 1378 else SOME(fromCstring style) 1379 in 1380 { owner = owner, context = if isHdcNull hdc then NONE else SOME hdc, 1381 logFont = SOME(toLF(deref logf)), pointSize = pointSize, 1382 (* Remove CF_LIMITSIZE and/or CF_INITTOLOGFONTSTRUCT *) 1383 flags = ChooseFontFlags.intersect[ChooseFontFlags.fromWord flags], 1384 colors = colors, style = style, 1385 fontType = 1386 ChooseFontTypes.fromWord(LargeWord.andb(LargeWord.fromInt types, 0wxffff)), 1387 size = minMax} 1388 end 1389 in 1390 fun ChooseFont (arg: CHOOSEFONT): CHOOSEFONT option = 1391 let 1392 val converted = toCChooseFont arg 1393 val result = 1394 winCall1 (commdlg "ChooseFontA") POINTER BOOL converted 1395 in 1396 if result 1397 then SOME(fromCChooseFont converted) 1398 else NONE 1399 end 1400 1401 end 1402 1403 structure ChooseColorFlags :> 1404 sig 1405 include BIT_FLAGS 1406 val CC_ANYCOLOR : flags 1407 val CC_FULLOPEN : flags 1408 val CC_PREVENTFULLOPEN : flags 1409 val CC_RGBINIT : flags 1410 val CC_SHOWHELP : flags 1411 val CC_SOLIDCOLOR : flags 1412 end 1413 = 1414 struct 1415 type flags = SysWord.word 1416 fun toWord f = f 1417 fun fromWord f = f 1418 val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 1419 fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 1420 fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 1421 fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) 1422 1423 val CC_RGBINIT = 0wx00000001 1424 val CC_FULLOPEN = 0wx00000002 1425 val CC_PREVENTFULLOPEN = 0wx00000004 1426 val CC_SHOWHELP = 0wx00000008 1427 (*val CC_ENABLEHOOK = 0wx00000010 1428 val CC_ENABLETEMPLATE = 0wx00000020 1429 val CC_ENABLETEMPLATEHANDLE = 0wx00000040*) 1430 val CC_SOLIDCOLOR = 0wx00000080 1431 val CC_ANYCOLOR = 0wx00000100 1432 1433 val all = flags[CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, 1434 CC_SHOWHELP, CC_SOLIDCOLOR, CC_ANYCOLOR] 1435 1436 val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all 1437 end 1438 1439 type CHOOSECOLOR = 1440 { 1441 owner: HWND option, 1442 result: COLORREF, 1443 customColors: COLORREF list, 1444 flags: ChooseColorFlags.flags 1445 } 1446 1447 local 1448 val CHOOSECOLOR = cStruct9(UINT, HWNDOPT, INT, COLORREF, POINTER, WORD, 1449 INT, INT, INT) 1450 (* The custom colours are held in an array of 16 elements. *) 1451 val CUSTOM = cStruct16(COLORREF, COLORREF, COLORREF, COLORREF, 1452 COLORREF, COLORREF, COLORREF, COLORREF, 1453 COLORREF, COLORREF, COLORREF, COLORREF, 1454 COLORREF, COLORREF, COLORREF, COLORREF) 1455 val (toCC, fromCC, ccStruct) = breakConversion CHOOSECOLOR 1456 val (toM, fromM, mStruct) = breakConversion CUSTOM 1457 val (toCR, fromCR, cref) = breakConversion COLORREF 1458 1459 fun toCChooseColor { 1460 owner: HWND option, 1461 result: COLORREF, 1462 customColors: COLORREF list, 1463 flags: ChooseColorFlags.flags 1464 } = 1465 let 1466 val custom = alloc 1 mStruct 1467 val black = fromCR(RGB{red=0, green=0, blue=0}) 1468 fun fillCustom(_, 16) = () 1469 | fillCustom([], i) = 1470 (assign cref (offset i cref custom) black; fillCustom([], i+1)) 1471 | fillCustom(hd::tl, i) = 1472 (assign cref (offset i cref custom) (fromCR hd); fillCustom(tl, i+1)) 1473 in 1474 fillCustom(customColors, 0); 1475 address( 1476 fromCC(sizeof ccStruct, owner, 0, result, address custom, 1477 ChooseColorFlags.toWord flags, 0, 0, 0)) 1478 end 1479 1480 fun fromCChooseColor v : CHOOSECOLOR = 1481 let 1482 val (_, owner, _, result, custom, flags, _, _, _) = toCC(deref v) 1483 val custom = 1484 List.tabulate(16, fn i => toCR(offset i cref(deref custom))) 1485 in 1486 { owner = owner, flags = ChooseColorFlags.fromWord flags, 1487 customColors = custom, result = result} 1488 end 1489 in 1490 fun ChooseColor (arg: CHOOSECOLOR): CHOOSECOLOR option = 1491 let 1492 val converted = toCChooseColor arg 1493 val result = 1494 winCall1 (commdlg "ChooseColorA") POINTER BOOL converted 1495 in 1496 if result 1497 then SOME(fromCChooseColor converted) 1498 else NONE 1499 end 1500 end 1501*) 1502(* 1503typedef struct tagCHOOSECOLORA { 1504 DWORD lStructSize; 1505 HWND hwndOwner; 1506 HWND hInstance; 1507 COLORREF rgbResult; 1508 COLORREF* lpCustColors; 1509 DWORD Flags; 1510 LPARAM lCustData; 1511 LPCCHOOKPROC lpfnHook; 1512 LPCSTR lpTemplateName; 1513} CHOOSECOLORA, *LPCHOOSECOLORA; 1514 1515*) 1516(* 1517ChooseColor 1518PrintDlgEx - NT 5.0 and later only 1519 1520The following application-defined hook procedures are used with common dialog boxes. 1521 1522CCHookProc 1523CFHookProc 1524FRHookProc 1525OFNHookProc 1526OFNHookProcOldStyle 1527PagePaintHook 1528PageSetupHook 1529PrintHookProc 1530SetupHookProc 1531*) 1532 end 1533end; 1534