├── .gitignore ├── LICENSE.md ├── README.md ├── source └── dpiawaremanager.prg └── testing ├── Fox-64.ico ├── Fox_528px.png ├── Fox_96px.png ├── dpi-testing.PJT ├── dpi-testing.exe.manifest ├── dpi-testing.pjx ├── dpi-testing.prg ├── forms └── thisFolderIntentionallyLeftEmpty ├── foxydialog.prg ├── information on displays.SCT ├── information on displays.scx ├── monitor dpi in screen.SCT ├── monitor dpi in screen.scx ├── unmanagedforms └── thisFolderIntentionallyLeftEmpty └── vfp2c32.fll /.gitignore: -------------------------------------------------------------------------------- 1 | *.BAK 2 | *.FXP 3 | *.exe 4 | FOXUSER.* 5 | temp/*.* 6 | testing/forms/*.* 7 | !testing/forms/thisFolderIntentionallyLeftEmpty 8 | testing/unmanagedforms/*.* 9 | !testing/unmanagedforms/thisFolderIntentionallyLeftEmpty 10 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # UNLICENSE # 2 | 3 | This is free and unencumbered software released into the public domain. 4 | 5 | Anyone is free to copy, modify, publish, use, compile, sell, or 6 | distribute this software, either in source code form or as a compiled 7 | binary, for any purpose, commercial or non-commercial, and by any 8 | means. 9 | 10 | In jurisdictions that recognize copyright laws, the author or authors 11 | of this software dedicate any and all copyright interest in the 12 | software to the public domain. We make this dedication for the benefit 13 | of the public at large and to the detriment of our heirs and 14 | successors. We intend this dedication to be an overt act of 15 | relinquishment in perpetuity of all present and future rights to this 16 | software under copyright law. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 21 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 22 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 23 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 24 | OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | For more information, please refer to <[http://unlicense.org](http://unlicense.org)> -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DPIAwareManager 2 | 3 | A DPI-aware manager class for VFP applications. 4 | 5 | ## Purpose 6 | 7 | DPIAwareManager aims to facilitate the use of VFP applications in High DPI monitors. 8 | 9 | ## The problem 10 | 11 | Modern Windows display DPI-unaware VFP applications in High DPI monitors for which a text-scaling is set higher than 100% as it does with any Win32 application. 12 | 13 | Windows scales the bitmap of the rendered graphic objects to match the percentage. As a result, the process produces text and graphics not as sharp as the developer initially designed. 14 | 15 | In the case of VFP9 applications that use the Report Behavior 90, it also means that reports will have their objects misplaced and incorrectly sized. 16 | 17 | ## A halfway solution 18 | 19 | A VFP9 application can declare itself to be DPI-aware by including a manifest stating so. 20 | 21 | This declaration will instruct Windows not to interfere in the rendering of forms and reports. Blurriness and misalignments, as above, won't occur. 22 | 23 | But, on the other hand, the application won't honor any display scaling above 100%. In High DPI monitors, set to higher scales, VFP applications will look small and smaller as the percentage increases. 24 | 25 | ## A more comprehensive solution 26 | 27 | The DPIAwareManager class aims to address the problem in its entirety by providing a specific framework that an application may use to manage the scaling of screen and forms objects. 28 | 29 | A managed application becomes aware of the conditions of the monitor(s) on which it displays its forms and automatically adjusts the dimensional and positional properties of the graphic objects. 30 | 31 | Since the conditions may vary during the execution of the application, the awareness is a continuing process. The user may move the screen or top-level forms to monitors with different scales or change the monitor's text size percentage, and the manager reacts to changes as these as they happen. 32 | 33 | The manager tries to be as unobtrusive as possible. Ideally, the application screen and forms won't even notice they've become DPI-aware. 34 | 35 | For the cases where this transparency is not possible or desirable, the manager grants a more refined control to the application, the form, or the control. 36 | 37 | Reference reading: [High-DPI application development](https://docs.microsoft.com/en-us/windows/win32/hidpi/high-dpi-desktop-application-development-on-windows) 38 | 39 | ## In use (basics) 40 | 41 | DPIAwareManager class definition comes in a single program file. Executing it will be enough to put the class in scope. 42 | 43 | To manage a form or the `_Screen` object, call the `Manage()` method. Depending on the application framework, this may proceed in different manners. 44 | 45 | ```foxpro 46 | * integration with a typical form manager 47 | LOCAL DPI AS DPIAwareManager 48 | 49 | m.DPI = CREATEOBJECT("DPIAwareManager") 50 | m.DPI.Manage(_Screen) 51 | 52 | DO FORM someform.scx NOSHOW NAME formReference LINKED 53 | 54 | m.DPI.Manage(m.FormReference) 55 | m.FormReference.Show() 56 | ``` 57 | 58 | In the absence of a central form manager in the application, forms can initiate their DPI-aware management. 59 | 60 | ```foxpro 61 | * no form manager, forms are on their own 62 | PUBLIC DPI AS DPIAwareManager 63 | 64 | m.DPI = CREATEOBJECT("DPIAwareManager") 65 | 66 | DO someform.scx 67 | 68 | * In the form's Init() method: 69 | m.DPI.Manage(This) 70 | ``` 71 | 72 | ## Reference 73 | 74 | Available from the repository's [wiki](https://github.com/atlopes/DPIAwareManager/wiki). 75 | 76 | ## Quick testing 77 | 78 | The manager is per-monitor aware, so you may work with different monitors having different scales. 79 | 80 | To experiment, build the project in the testing folder and run the resulting dpi-testing executable. 81 | 82 | Important: The executable filename must be "dpi-testing.exe" so that the builder will link the manifest into the executable. 83 | 84 | To try with forms of your own, drop a set of self-contained copies in the testing/forms folder. Don't forget to include both SCX and SCT files and note that the testing has no error handler in place. 85 | 86 | You may want to try with top-level or in-screen forms. Testing with several top-level forms in different monitors will demonstrate that an application may have forms of different scales running at the same time. 87 | 88 | Important note: work in progress. It was not tested outside the particular environment of its development. Things may be missing or not working at all. 89 | 90 | ## Acknowledgements and credits 91 | 92 | - The sizer components of the DPIAwareManager class build on the logic of Irwin Rodriguez's [VFPStretch](https://github.com/Irwin1985/VFPStretch). 93 | - The DPI-Testing application uses [FoxyDialog](http://vfpimaging.blogspot.com/2020/06/foxydialogs-v10-going-much-forward-with.html), by Cesar Chalom, which requires the [VFP2C32](https://github.com/ChristianEhlscheid/vfp2c32) library, by Christian Ehlscheid. 94 | - Graphics by [Icons8](https://icons8.com/), creators of extraordinary iconography. 95 | -------------------------------------------------------------------------------- /source/dpiawaremanager.prg: -------------------------------------------------------------------------------- 1 | 2 | SET PROCEDURE TO (SYS(16)) ADDITIVE 3 | 4 | #DEFINE WM_DPICHANGED 0x02E0 5 | #DEFINE WM_SETICON 0x0080 6 | 7 | #DEFINE SIZEOF_MONITORINFO 0h28000000 8 | 9 | #DEFINE DPI_STANDARD 96 10 | #DEFINE DPI_STANDARD_SCALE 100 11 | #DEFINE DPI_MAX_SCALE 300 12 | #DEFINE DPI_SCALE_INCREMENT 25 13 | 14 | #DEFINE DPIAW_NO_REPOSITION 0 15 | #DEFINE DPIAW_RELATIVE_TOP_LEFT 0x01 16 | #DEFINE DPIAW_CONSTRAINT_DIMENSION 0x02 17 | 18 | #DEFINE ICON_SMALL 0 19 | #DEFINE ICON_BIG 1 20 | 21 | #DEFINE DC_LOGPIXELSX 88 22 | 23 | Define Class DPIAwareManager As Custom 24 | 25 | * process DPI awareness type 26 | AwarenessType = 0 27 | 28 | * logging 29 | Logging = .F. 30 | 31 | * compensation for what is cut from a form when changing DPI (from 125 to 300%) 32 | * to be confirmed... 33 | WidthAdjustments = "2,6,8,10,12,14,16,18" 34 | HeightAdjustments = "8,17,25,32,40,49,56,63" 35 | 36 | * the collection of alternative fonts 37 | ADD OBJECT PROTECTED AlternativeFontNames AS Collection 38 | HIDDEN AlternativeFontNamesScale 39 | AlternativeFontNamesScale = DPI_STANDARD_SCALE 40 | 41 | * system function to gather information regarding DPI 42 | HIDDEN SystemInfoFunction 43 | SystemInfoFunction = 0 44 | 45 | * available displays 46 | ADD OBJECT Displays AS Collection 47 | ExtendedDisplaysOnly = .T. 48 | 49 | FUNCTION Init 50 | 51 | DECLARE LONG GetWindowDC IN WIN32API AS dpiaw_GetWindowDC ; 52 | LONG hWnd 53 | DECLARE LONG ReleaseDC IN WIN32API AS dpiaw_ReleaseDC ; 54 | LONG hWnd, LONG hDC 55 | DECLARE LONG GetDeviceCaps IN WIN32API AS dpiaw_GetDeviceCaps ; 56 | LONG hDC, INTEGER CapIndex 57 | DECLARE LONG MonitorFromWindow IN WIN32API AS dpiaw_MonitorFromWindow ; 58 | LONG hWnd, INTEGER Flags 59 | DECLARE LONG MonitorFromPoint IN WIN32API AS dpiaw_MonitorFromPoint ; 60 | LONG X, LONG Y, INTEGER Flags 61 | DECLARE INTEGER GetMonitorInfo IN WIN32API AS dpiaw_GetMonitorInfo ; 62 | LONG hMonitor, STRING @ MonitorInfo 63 | DECLARE INTEGER EnumDisplaySettings IN WIN32API AS dpiaw_EnumDisplaySettings ; 64 | STRING lpszDeviceName, INTEGER iModeNum, STRING @lpDevMode 65 | DECLARE INTEGER EnumDisplayDevices IN WIN32API AS dpiaw_EnumDisplayDevices ; 66 | STRING lpDevice, INTEGER iDevNum, ; 67 | STRING @lpDisplayDevice, INTEGER dwFlags 68 | DECLARE INTEGER ExtractIcon IN shell32 AS dpiaw_ExtractIcon ; 69 | INTEGER hInst, STRING FileName, INTEGER IndexIcon 70 | DECLARE INTEGER SendMessage IN user32 AS dpiaw_SendMessage ; 71 | INTEGER hWnd, INTEGER Msg, INTEGER wParam, INTEGER lParam 72 | 73 | TRY 74 | DECLARE LONG GetDpiForMonitor IN SHCORE.DLL AS dpiaw_GetDpiForMonitor ; 75 | LONG hMonitor, INTEGER dpiType, INTEGER @ dpiX, INTEGER @ dpiY 76 | This.SystemInfoFunction = 1 77 | CATCH 78 | ENDTRY 79 | 80 | TRY 81 | DECLARE INTEGER GetDpiForWindow IN WIN32API AS dpiaw_GetDpiForWindow ; 82 | LONG hWnd 83 | This.SystemInfoFunction = 2 84 | CATCH 85 | ENDTRY 86 | 87 | * get the awareness type of the process 88 | TRY 89 | DECLARE INTEGER IsProcessDPIAware IN WIN32API AS dpiaw_IsProcessDPIAware 90 | IF dpiaw_IsProcessDPIAware() != 0 91 | This.AwarenessType = 1 92 | ENDIF 93 | TRY 94 | DECLARE INTEGER GetProcessDpiAwareness IN Shcore.dll AS dpiaw_GetProcessDpiAwareness LONG Process, LONG @ Awareness 95 | LOCAL Awareness AS Integer 96 | m.Awareness = 0 97 | IF dpiaw_GetProcessDpiAwareness(0, @m.Awareness) == 0 98 | This.AwarenessType = m.Awareness 99 | ENDIF 100 | CATCH 101 | ENDTRY 102 | CATCH 103 | ENDTRY 104 | 105 | This.GetDisplaysInfo() 106 | 107 | ENDFUNC 108 | 109 | **************************************************************************************** 110 | #DEFINE METHODS_MANAGEMENT 111 | **************************************************************************************** 112 | 113 | * Manage 114 | * Puts a form under DPI-awareness management 115 | * It should be called before the form is shown 116 | FUNCTION Manage (AForm AS Form, Constraints AS Integer) AS Void 117 | 118 | * add DPI-aware related properties 119 | This.AddDPIProperty(m.AForm, "DPIAwareManager", This) 120 | This.AddDPIProperty(m.AForm, "hMonitor", dpiaw_MonitorFromWindow(m.AForm.HWnd, 0)) 121 | This.AddDPIProperty(m.AForm, "DPIMonitorInfo", This.GetMonitorInfo(m.AForm.hMonitor, .F.)) 122 | This.AddDPIProperty(m.AForm, "DPIMonitorClientAreaInfo", This.GetMonitorInfo(m.AForm.hMonitor, .T.)) 123 | This.AddDPIProperty(m.AForm, "DPIScale", This.GetMonitorDPIScale(m.AForm)) 124 | This.AddDPIProperty(m.AForm, "DPINewScale", m.AForm.DPIScale) 125 | This.AddDPIProperty(m.AForm, "DPIAutoConstraint", ; 126 | IIF(PCOUNT() == 1, ; 127 | IIF(m.AForm == _Screen OR m.AForm.ShowWindow == 2, DPIAW_NO_REPOSITION, DPIAW_RELATIVE_TOP_LEFT), ; 128 | m.Constraints)) 129 | This.AddDPIProperty(m.AForm, "DPIManagerEvent", "Manage") 130 | This.AddDPIProperty(m.AForm, "DPIScaling", .F.) 131 | 132 | * save the original value of dimensional and positional properties of the form 133 | This.SaveContainer(m.AForm) 134 | 135 | * bind the form to the two listeners for changes of the DPI scale 136 | IF m.AForm == _Screen 137 | BINDEVENT(_Screen, "Moved", This, "CheckDPIScaleChange") 138 | ENDIF 139 | BINDEVENT(m.AForm.hWnd, WM_DPICHANGED, This, "WMCheckDPIScaleChange") 140 | * and to clean-up methods 141 | BINDEVENT(m.AForm, "Destroy", This, "CleanUp") 142 | 143 | * if the form was created in a non 100% scale monitor, perform an initial scaling without preadjustment 144 | IF m.AForm.DPINewScale != DPI_STANDARD_SCALE 145 | IF m.AForm = _Screen AND PEMSTATUS(_Screen, "DPIAwareScreenManager", 5) 146 | _Screen.DPIAwareScreenManager.SelfManage(DPI_STANDARD_SCALE, m.AForm.DPINewScale) 147 | ENDIF 148 | This.Scale(m.AForm, DPI_STANDARD_SCALE, m.AForm.DPINewScale, .T.) 149 | ENDIF 150 | 151 | ENDFUNC 152 | 153 | * ManageFont 154 | * Prepare a font to be managed whenever it occurs as a FontName control property 155 | FUNCTION ManageFont (OriginalFontName AS String, Scale AS Integer, AdjustedFontName AS String) 156 | 157 | LOCAL FontIndex AS Integer 158 | LOCAL AlternativeFont AS DPIAwareAlternativeFont 159 | 160 | * locate an existing font name controller object in the collection 161 | m.FontIndex = This.AlternativeFontNames.GetKey(UPPER(m.OriginalFontName)) 162 | * create it, if it does not exist 163 | IF m.FontIndex == 0 164 | m.AlternativeFont = CREATEOBJECT("DPIAwareAlternativeFont", m.OriginalFontName) 165 | This.AlternativeFontNames.Add(m.AlternativeFont, UPPER(m.OriginalFontName)) 166 | ELSE 167 | m.AlternativeFont = This.AlternativeFontNames.Item(m.FontIndex) 168 | ENDIF 169 | 170 | * add the alternative font name for a given scale (and up) 171 | m.AlternativeFont.AddAlternative(m.Scale, m.AdjustedFontName) 172 | 173 | ENDFUNC 174 | 175 | * CleanUp 176 | * Clean up a managed form 177 | FUNCTION CleanUp () 178 | 179 | LOCAL ARRAY SourceEvent(1) 180 | AEVENTS(m.SourceEvent, 0) 181 | 182 | LOCAL DPIAwareForm AS Form 183 | m.DPIAwareForm = m.SourceEvent(1) 184 | 185 | TRY 186 | m.DPIAwareForm.DPIMonitorInfo = .NULL. 187 | CATCH 188 | ENDTRY 189 | TRY 190 | m.DPIAwareForm.DPIMonitorClientAreaInfo = .NULL. 191 | CATCH 192 | ENDTRY 193 | 194 | ENDFUNC 195 | 196 | **************************************************************************************** 197 | #DEFINE METHODS_SYSTEM_INFORMATION 198 | **************************************************************************************** 199 | 200 | * GetMonitorDPIScale 201 | * Returns the DPI scale of a monitor that a form is using. 202 | * The scale is a percentage (100%, 125%, ...). 203 | FUNCTION GetMonitorDPIScale (DPIAwareForm AS Form) AS Integer 204 | LOCAL dpiX AS Integer 205 | LOCAL hDC AS Integer 206 | 207 | * use the best available function to get the information 208 | TRY 209 | DO CASE 210 | CASE This.SystemInfoFunction = 2 211 | m.dpiX = dpiaw_GetDpiForWindow(m.DPIAwareForm.HWnd) 212 | CASE This.SystemInfoFunction = 1 && not for Per-Monitor aware (AwarenessType = 2) 213 | m.dpiX = 0 214 | dpiaw_GetDpiForMonitor(m.DPIAwareForm.hMonitor, 0, @m.dpiX, @m.dpiX) 215 | OTHERWISE 216 | m.hDC = dpiaw_GetWindowDC(m.DPIAwareForm.HWnd) 217 | m.dpiX = dpiaw_GetDeviceCaps(m.hDC, DC_LOGPIXELSX) 218 | dpiaw_ReleaseDC(m.DPIAwareForm.HWnd, m.hDC) 219 | ENDCASE 220 | CATCH 221 | m.dpiX = DPI_STANDARD 222 | ENDTRY 223 | 224 | * returns a percentage relative to 96DPI (the standard DPI) 225 | RETURN MIN(MAX(INT(m.dpiX / DPI_STANDARD * DPI_STANDARD_SCALE), DPI_STANDARD_SCALE), DPI_MAX_SCALE) 226 | 227 | ENDFUNC 228 | 229 | * GetMonitorInfo 230 | * Returns dimensional and position information of a monitor. 231 | FUNCTION GetMonitorInfo (hMonitor AS Integer, IsWorkArea AS Logical) AS Object 232 | 233 | LOCAL MonitorInfoStructure AS String 234 | LOCAL Rect AS String 235 | LOCAL MonitorInfo AS Empty 236 | 237 | m.MonitorInfoStructure = SIZEOF_MONITORINFO + REPLICATE(CHR(0), 36) 238 | 239 | dpiaw_GetMonitorInfo(m.hMonitor, @m.MonitorInfoStructure) 240 | 241 | IF !m.IsWorkArea 242 | m.Rect = SUBSTR(m.MonitorInfoStructure, 5, 16) 243 | ELSE 244 | m.Rect = SUBSTR(m.MonitorInfoStructure, 21, 16) 245 | ENDIF 246 | 247 | m.MonitorInfo = CREATEOBJECT("Empty") 248 | ADDPROPERTY(m.MonitorInfo, "Left", CTOBIN(SUBSTR(m.Rect, 1, 4), "4RS")) 249 | ADDPROPERTY(m.MonitorInfo, "Top", CTOBIN(SUBSTR(m.Rect, 5, 4), "4RS")) 250 | ADDPROPERTY(m.MonitorInfo, "Right", CTOBIN(SUBSTR(m.Rect, 9, 4), "4RS")) 251 | ADDPROPERTY(m.MonitorInfo, "Bottom", CTOBIN(SUBSTR(m.Rect, 13, 4), "4RS")) 252 | ADDPROPERTY(m.MonitorInfo, "Width", m.MonitorInfo.Right - m.MonitorInfo.Left) 253 | ADDPROPERTY(m.MonitorInfo, "Height", m.MonitorInfo.Bottom - m.MonitorInfo.Top) 254 | 255 | RETURN m.MonitorInfo 256 | 257 | ENDFUNC 258 | 259 | * GetDisplaysInfo 260 | * Fetchs information on (active) displays and returns its number 261 | FUNCTION GetDisplaysInfo () AS Integer 262 | 263 | * refresh the collection of displays 264 | This.Displays.Remove(-1) 265 | 266 | #DEFINE DISPLAY_DEVICE_ACTIVE 1 267 | #DEFINE DISPLAY_DEVICE_PRIMARY_DEVICE 4 268 | #DEFINE DISPLAY_DEVICE_MIRRORING_DRIVER 8 269 | 270 | #DEFINE ENUM_CURRENT_SETTINGS -1 271 | 272 | #DEFINE MONITOR_DEFAULTTONEAREST 2 273 | 274 | #DEFINE SIZEOF_DISPLAYDEVICE 424 275 | #DEFINE SIZEOF_MONITORINFOEX 72 276 | 277 | LOCAL CStruct AS String 278 | LOCAL StateFlags AS Integer 279 | LOCAL MIndex AS Integer 280 | LOCAL MInfo AS Empty 281 | LOCAL VFPMonitor AS Integer 282 | LOCAL dpiX AS Integer 283 | 284 | * get VFP's monitor handle, for later 285 | m.VFPMonitor = dpiaw_MonitorFromWindow(_vfp.hWnd, MONITOR_DEFAULTTONEAREST) 286 | 287 | m.MIndex = 0 288 | 289 | * go through all available displays 290 | DO WHILE .T. 291 | 292 | m.CStruct = BINTOC(SIZEOF_DISPLAYDEVICE, "4RS") + REPLICATE(0h00, SIZEOF_DISPLAYDEVICE - 4) 293 | 294 | * this marks the end of the list, no more monitors 295 | IF dpiaw_EnumDisplayDevices(.NULL., m.MIndex, @m.CStruct, 0) == 0 296 | EXIT 297 | ENDIF 298 | 299 | m.StateFlags = CTOBIN(SUBSTR(m.CStruct, 165, 2), "2RS") 300 | * ignore inactive or mirrored displays? continue going through all monitors 301 | IF This.ExtendedDisplaysOnly AND (!BITTEST(m.StateFlags, 0) OR BITTEST(m.StateFlags, 3)) 302 | m.MIndex = m.MIndex + 1 303 | LOOP 304 | ENDIF 305 | 306 | * prepare an object to hold the information 307 | m.MInfo = CREATEOBJECT("Empty") 308 | 309 | ADDPROPERTY(m.MInfo, "DeviceIndex", m.MIndex) 310 | 311 | ADDPROPERTY(m.MInfo, "DeviceName", GETWORDNUM(SUBSTR(m.CStruct, 5, 32) + 0h00, 1, 0h00)) 312 | ADDPROPERTY(m.MInfo, "DeviceString", GETWORDNUM(SUBSTR(m.CStruct, 37, 128) + 0h00, 1, 0h00)) 313 | ADDPROPERTY(m.MInfo, "DeviceKey", GETWORDNUM(SUBSTR(m.CStruct, 297, 128) + 0h00, 1, 0h00)) 314 | ADDPROPERTY(m.MInfo, "PrimaryDevice", BITTEST(m.StateFlags, 2)) 315 | ADDPROPERTY(m.MInfo, "ActiveDevice", BITTEST(m.StateFlags, 0)) 316 | ADDPROPERTY(m.MInfo, "StateFlags", m.StateFlags) 317 | 318 | * fetch the monitor name now that a device name is found 319 | m.CStruct = BINTOC(SIZEOF_DISPLAYDEVICE, "4RS") + REPLICATE(0h00, SIZEOF_DISPLAYDEVICE- 4) 320 | 321 | dpiaw_EnumDisplayDevices(m.MInfo.DeviceName, 0, @m.CStruct, 0) 322 | 323 | ADDPROPERTY(m.MInfo, "MonitorName", GETWORDNUM(SUBSTR(m.CStruct, 37, 128) + 0h00, 1, 0h00)) 324 | 325 | * fetch the settings for the monitor 326 | m.CStruct = REPLICATE(CHR(0), 1024) 327 | 328 | dpiaw_EnumDisplaySettings(m.MInfo.DeviceName, ENUM_CURRENT_SETTINGS, @m.CStruct) 329 | 330 | ADDPROPERTY(m.MInfo, "Left", CTOBIN(SUBSTR(m.CStruct, 45, 4), "4RS")) 331 | ADDPROPERTY(m.MInfo, "Top", CTOBIN(SUBSTR(m.CStruct, 49, 4), "4RS")) 332 | ADDPROPERTY(m.MInfo, "Width", CTOBIN(SUBSTR(m.CStruct, 109, 4), "4RS")) 333 | ADDPROPERTY(m.MInfo, "Height", CTOBIN(SUBSTR(m.CStruct, 113, 4), "4RS")) 334 | ADDPROPERTY(m.MInfo, "BitsPerPixel", CTOBIN(SUBSTR(m.CStruct, 105, 4), "4RS")) 335 | ADDPROPERTY(m.MInfo, "Orientation", CTOBIN(SUBSTR(m.CStruct, 53, 4), "4RS")) 336 | ADDPROPERTY(m.MInfo, "FixedOutput", CTOBIN(SUBSTR(m.CStruct, 57, 4), "4RS")) 337 | ADDPROPERTY(m.MInfo, "Flags", CTOBIN(SUBSTR(m.CStruct, 117, 4), "4RS")) 338 | ADDPROPERTY(m.MInfo, "Frequency", CTOBIN(SUBSTR(m.CStruct, 121, 4), "4RS")) 339 | 340 | * we have the top left coordinates, get the monitor handle 341 | ADDPROPERTY(m.MInfo, "hMonitor", dpiaw_MonitorFromPoint(m.MInfo.Left, m.MInfo.Top, MONITOR_DEFAULTTONEAREST)) 342 | 343 | ADDPROPERTY(m.MInfo, "_ScreenHost", m.MInfo.hMonitor == m.VFPMonitor) 344 | 345 | * and try to get its DPI setting 346 | TRY 347 | m.dpiX = DPI_STANDARD 348 | dpiaw_GetDpiForMonitor(m.MInfo.hMonitor, 0, @m.dpiX, @m.dpiX) 349 | CATCH 350 | m.dpiX = 0 351 | ENDTRY 352 | 353 | * store it and calculate the logical width and height 354 | ADDPROPERTY(m.MInfo, "DPI", m.dpiX) 355 | ADDPROPERTY(m.MInfo, "DPIScale", INT(m.dpiX * DPI_STANDARD_SCALE / DPI_STANDARD)) 356 | ADDPROPERTY(m.MInfo, "DPIAware_Width", FLOOR(m.MInfo.Width * DPI_STANDARD / EVL(m.dpiX, DPI_STANDARD))) 357 | ADDPROPERTY(m.MInfo, "DPIAware_Height", FLOOR(m.MInfo.Height * DPI_STANDARD / EVL(m.dpiX, DPI_STANDARD))) 358 | 359 | * add to the collection of displays 360 | This.Displays.Add(m.MInfo) 361 | 362 | m.MIndex = m.MIndex + 1 363 | 364 | ENDDO 365 | 366 | * >= 1, or something really wrong happened... 367 | RETURN This.Displays.Count 368 | 369 | ENDFUNC 370 | 371 | * SetMonitorInfo 372 | * Sets positional, dimensional, and DPI information of current monitor 373 | FUNCTION SetMonitorInfo (DPIAwareForm AS Form, Source AS Form) 374 | 375 | IF PCOUNT() == 1 376 | m.DPIAwareForm.hMonitor = dpiaw_MonitorFromWindow(m.DPIAwareForm.hWnd, 0) 377 | ELSE 378 | m.DPIAwareForm.hMonitor = m.Source.hMonitor 379 | ENDIF 380 | m.DPIAwareForm.DPIMonitorInfo = .NULL. 381 | m.DPIAwareForm.DPIMonitorInfo = This.GetMonitorInfo(m.DPIAwareForm.hMonitor, .F.) 382 | m.DPIAwareForm.DPIMonitorClientAreaInfo = .NULL. 383 | m.DPIAwareForm.DPIMonitorClientAreaInfo = This.GetMonitorInfo(m.DPIAwareForm.hMonitor, .T.) 384 | 385 | ENDFUNC 386 | 387 | * GetFormDPIScale 388 | * Returns the DPI Scale of the form that contains an object. 389 | FUNCTION GetFormDPIScale (DPIAwareObject AS Object) AS Integer 390 | 391 | LOCAL ObjectForm AS Form 392 | 393 | m.ObjectForm = This.GetThisform(m.DPIAwareObject) 394 | 395 | RETURN IIF(!ISNULL(m.ObjectForm), m.ObjectForm.DPIScale, DPI_STANDARD_SCALE) 396 | 397 | ENDFUNC 398 | 399 | **************************************************************************************** 400 | #DEFINE METHODS_AKNOWLEDGE_AND_REACT_TO_DPI_CHANGES 401 | **************************************************************************************** 402 | 403 | * WMCheckDPIScaleChange 404 | * Receives a Windows message when the DPI has changed for the hWnd of a form. 405 | FUNCTION WMCheckDPIScaleChange (hWnd, uMsg, wParam, lParam) 406 | 407 | LOCAL DPIAwareForm AS Form 408 | LOCAL CreatedForm AS 409 | 410 | m.DPIAwareForm = .NULL. 411 | 412 | * look for all forms until the matching hWnd is found 413 | FOR EACH m.CreatedForm AS Form IN _Screen.Forms 414 | IF m.CreatedForm.HWnd = m.hWnd 415 | m.DPIAwareForm = m.CreatedForm 416 | EXIT 417 | ENDIF 418 | ENDFOR 419 | 420 | IF ISNULL(m.DPIAwareForm) 421 | RETURN 0 422 | ENDIF 423 | 424 | m.DPIAwareForm.DPIManagerEvent = "WindowsMessage" 425 | 426 | * refresh information on the monitor where the form is being displayed 427 | This.SetMonitorInfo(m.DPIAwareForm) 428 | 429 | * proceed to the actual method that performs the rescaling (the new DPI scale is passed as a percentage) 430 | RETURN This.ChangeFormDPIScale(m.DPIAwareForm, MIN(MAX(BITAND(m.wParam, 0x07FFF) / DPI_STANDARD * DPI_STANDARD_SCALE, DPI_STANDARD_SCALE), DPI_MAX_SCALE)) 431 | ENDFUNC 432 | 433 | * CheckDPIScaleChange 434 | * Notice when a DPI has changed and triggered a Moved event. 435 | FUNCTION CheckDPIScaleChange () 436 | 437 | LOCAL ARRAY SourceEvent(1) 438 | AEVENTS(m.SourceEvent, 0) 439 | 440 | LOCAL DPIAwareForm AS Form 441 | m.DPIAwareForm = m.SourceEvent(1) 442 | 443 | * refresh information on the monitor where the form is being displayed 444 | This.SetMonitorInfo(m.DPIAwareForm) 445 | 446 | IF This.ChangeFormDPIScale(m.DPIAwareForm, This.GetMonitorDPIScale(m.DPIAwareForm)) = 0 447 | 448 | m.DPIAwareForm.DPIManagerEvent = "Moved" 449 | 450 | IF m.DPIAwareForm = _Screen 451 | 452 | FOR EACH m.DPIAwareForm AS Form IN _Screen.Forms 453 | IF m.DPIAwareForm.BaseClass == "Form" AND m.DPIAwareForm.ShowWindow = 0 AND PEMSTATUS(m.DPIAwareForm, "DPIAware", 5) AND m.DPIAwareForm.DPIAware 454 | * refresh information on the monitor where the form is being displayed 455 | This.SetMonitorInfo(m.DPIAwareForm, _Screen) 456 | This.ChangeFormDPIScale(m.DPIAwareForm, _Screen.DPIScale) 457 | ENDIF 458 | ENDFOR 459 | 460 | ENDIF 461 | 462 | ENDIF 463 | 464 | ENDFUNC 465 | 466 | * ChangeFormDPIScale 467 | * Change the DPI scale of a form. 468 | FUNCTION ChangeFormDPIScale (DPIAwareForm AS Form, NewDPIScale AS Integer) AS Integer 469 | 470 | LOCAL Ops AS Exception 471 | 472 | * act only if the scale of the form has changed (the _Screen may have only moved) 473 | IF m.NewDPIScale != m.DPIAwareForm.DPIScale 474 | 475 | LOCAL IsMaximized AS Logical 476 | 477 | m.IsMaximized = (m.DPIAwareForm.WindowState == 2) 478 | 479 | m.DPIAwareForm.DPINewScale = m.NewDPIScale 480 | m.DPIAwareForm.LockScreen = .T. 481 | 482 | * perform the actual scaling 483 | TRY 484 | 485 | This.Scale(m.DPIAwareForm, m.DPIAwareForm.DPIScale, m.NewDPIScale) 486 | This.EnforceFormConstraints(m.DPIAwareForm) 487 | 488 | IF m.DPIAwareForm = _Screen AND PEMSTATUS(_Screen, "DPIAwareScreenManager", 5) 489 | _Screen.DPIAwareScreenManager.SelfManage(_Screen.DPIScale, m.NewDPIScale) 490 | ENDIF 491 | 492 | CATCH TO m.oPS 493 | * quick dirty info on error 494 | MESSAGEBOX(TEXTMERGE("<> @ <> / <>")) 495 | ENDTRY 496 | 497 | m.DPIAwareForm.LockScreen = .F. 498 | m.DPIAwareForm.DPIScale = m.NewDPIScale 499 | 500 | IF m.IsMaximized 501 | m.DPIAwareForm.WindowState = 2 502 | ENDIF 503 | 504 | RETURN 0 505 | 506 | ENDIF 507 | 508 | RETURN -1 509 | 510 | ENDFUNC 511 | 512 | * EnforceFormConstraints 513 | * Constraints the dimension and position of the form (according to the DPIAutoConstraint property): 514 | * - DPIAW_RELATIVE_TOP_LEFT form is placed relative top left to its container (_Screen or monitor) 515 | * - DPIAW_CONSTRAINT_DIMENSION form won't be bigger than the target monitor 516 | FUNCTION EnforceFormConstraints (DPIAwareForm AS Form) 517 | 518 | LOCAL XYRatio AS Number 519 | LOCAL NewXYRatio AS Number 520 | LOCAL OverDimension AS Number 521 | LOCAL TargetDimension AS Number 522 | 523 | m.XYRatio = This.GetXYRatio(m.DPIAwareForm.DPIScale) 524 | m.NewXYRatio = This.GetXYRatio(m.DPIAwareForm.DPINewScale) 525 | 526 | IF BITAND(m.DPIAwareForm.DPIAutoConstraint, DPIAW_RELATIVE_TOP_LEFT) != 0 527 | m.DPIAwareForm.Top = (m.DPIAwareForm.Top / m.XYRatio) * m.NewXYRatio 528 | m.DPIAwareForm.Left = (m.DPIAwareForm.Left / m.XYRatio) * m.NewXYRatio 529 | ENDIF 530 | 531 | IF BITAND(m.DPIAwareForm.DPIAutoConstraint, DPIAW_CONSTRAINT_DIMENSION) != 0 532 | 533 | m.Monitor = This.GetMonitorInfo(m.DPIAwareForm.hMonitor, .T.) 534 | 535 | m.OverDimension = m.DPIAwareForm.Width - m.Monitor.Width 536 | IF m.OverDimension > 0 537 | m.TargetDimension = m.DPIAwareForm.Width - m.OverDimension 538 | IF m.DPIAwareForm.MinWidth = -1 OR (m.DPIAwareForm.MinWidth < m.TargetDimension) 539 | m.DPIAwareForm.Width = m.TargetDimension 540 | ENDIF 541 | ENDIF 542 | 543 | m.OverDimension = m.DPIAwareForm.Height - m.Monitor.Height 544 | IF m.OverDimension > 0 545 | m.TargetDimension = m.DPIAwareForm.Height - m.OverDimension 546 | IF m.DPIAwareForm.MinHeight = -1 OR (m.DPIAwareForm.MinHeight < m.TargetDimension) 547 | m.DPIAwareForm.Height = m.TargetDimension 548 | ENDIF 549 | ENDIF 550 | 551 | ENDIF 552 | 553 | ENDFUNC 554 | 555 | **************************************************************************************** 556 | #DEFINE METHODS_SAVE_ORIGINAL_PROPERTY_VALUES 557 | **************************************************************************************** 558 | 559 | * SaveContainer 560 | * Save the properties of a container object. 561 | FUNCTION SaveContainer (Ctrl AS Object) 562 | 563 | LOCAL SubCtrl AS Object 564 | 565 | This.SaveOriginalInfo(m.Ctrl) 566 | 567 | FOR EACH m.SubCtrl In m.Ctrl.Controls 568 | This.SaveControl(m.SubCtrl) 569 | ENDFOR 570 | 571 | ENDFUNC 572 | 573 | * SaveControl 574 | * Save the properties of an object. 575 | FUNCTION SaveControl (Ctrl AS Object) 576 | 577 | LOCAL SubCtrl AS Object 578 | 579 | IF !m.Ctrl.BaseClass $ "Custom,Timer" 580 | This.SaveOriginalInfo(m.Ctrl) 581 | ELSE 582 | RETURN 583 | ENDIF 584 | 585 | DO CASE 586 | 587 | CASE m.Ctrl.BaseClass == 'Container' 588 | This.SaveContainer(m.Ctrl) 589 | 590 | CASE m.Ctrl.BaseClass == 'Pageframe' 591 | 592 | FOR EACH SubCtrl IN m.Ctrl.Pages 593 | This.SaveContainer(m.SubCtrl) 594 | ENDFOR 595 | 596 | CASE m.Ctrl.BaseClass == 'Grid' 597 | 598 | FOR EACH SubCtrl IN m.Ctrl.Columns 599 | This.SaveOriginalInfo(m.SubCtrl) 600 | This.SaveContainer(m.SubCtrl) 601 | ENDFOR 602 | 603 | CASE m.Ctrl.BaseClass $ 'Commandgroup,Optiongroup' 604 | 605 | FOR EACH SubCtrl IN m.Ctrl.Buttons 606 | This.SaveOriginalInfo(m.SubCtrl) 607 | ENDFOR 608 | 609 | ENDCASE 610 | 611 | ENDFUNC 612 | 613 | * SaveOriginalProperty 614 | * Saves the original value of a property by creating a DPIAware_ new property. 615 | FUNCTION SaveOriginalProperty (Ctrl AS Object, Property AS String) 616 | 617 | IF PEMSTATUS(m.Ctrl, m.Property, 5) AND TYPE("m.Ctrl." + m.Property) != "U" 618 | This.AddDPIProperty(m.Ctrl, "DPIAware_" + m.Property, EVALUATE("m.Ctrl." + m.Property)) 619 | ENDIF 620 | 621 | ENDFUNC 622 | 623 | * SaveOriginalInfo 624 | * Saves the original information of an object (non-existing properties will be ignored). 625 | FUNCTION SaveOriginalInfo (Ctrl AS Object) 626 | 627 | IF !PEMSTATUS(m.Ctrl, "DPIAware", 5) 628 | This.AddDPIProperty(m.Ctrl, "DPIAware", .T.) 629 | ENDIF 630 | This.SaveOriginalProperty(m.Ctrl, "Anchor") 631 | This.SaveOriginalProperty(m.Ctrl, "BorderWidth") 632 | This.SaveOriginalProperty(m.Ctrl, "ColumnWidths") 633 | This.SaveOriginalProperty(m.Ctrl, "DrawWidth") 634 | This.SaveOriginalProperty(m.Ctrl, "FontName") 635 | This.SaveOriginalProperty(m.Ctrl, "FontSize") 636 | This.SaveOriginalProperty(m.Ctrl, "GridLineWidth") 637 | This.SaveOriginalProperty(m.Ctrl, "HeaderHeight") 638 | This.SaveOriginalProperty(m.Ctrl, "Height") 639 | This.SaveOriginalProperty(m.Ctrl, "Left") 640 | This.SaveOriginalProperty(m.Ctrl, "Margin") 641 | This.SaveOriginalProperty(m.Ctrl, "MaxHeight") 642 | This.SaveOriginalProperty(m.Ctrl, "MaxWidth") 643 | This.SaveOriginalProperty(m.Ctrl, "MinHeight") 644 | This.SaveOriginalProperty(m.Ctrl, "MinWidth") 645 | This.SaveOriginalProperty(m.Ctrl, "Partition") 646 | This.SaveOriginalProperty(m.Ctrl, "PictureMargin") 647 | This.SaveOriginalProperty(m.Ctrl, "PictureSpacing") 648 | This.SaveOriginalProperty(m.Ctrl, "RowHeight") 649 | This.SaveOriginalProperty(m.Ctrl, "Top") 650 | This.SaveOriginalProperty(m.Ctrl, "Width") 651 | 652 | This.SaveGraphicAlternatives(m.Ctrl, "DisabledPicture") 653 | This.SaveGraphicAlternatives(m.Ctrl, "DownPicture") 654 | This.SaveGraphicAlternatives(m.Ctrl, "DragIcon") 655 | This.SaveGraphicAlternatives(m.Ctrl, "Icon") 656 | This.SaveGraphicAlternatives(m.Ctrl, "MouseIcon") 657 | This.SaveGraphicAlternatives(m.Ctrl, "Picture") 658 | This.SaveGraphicAlternatives(m.Ctrl, "PictureVal") 659 | 660 | LOCAL CtrlsForm AS Form 661 | 662 | * if DPI awareness is controlled by the control itself or by its parents, give it the opportunity to save additional information 663 | IF PEMSTATUS(m.Ctrl, "DPIAwareSelfControl", 5) 664 | 665 | TRY 666 | DO CASE 667 | 668 | * the control manages itself 669 | CASE m.Ctrl.DPIAwareSelfControl == 1 670 | 671 | m.Ctrl.DPIAwareSaveOriginalInfo() 672 | 673 | * the form manages the control 674 | CASE m.Ctrl.DPIAwareSelfControl == 2 675 | 676 | m.CtrlsForm = This.GetThisform(m.Ctrl) 677 | IF !ISNULL(m.CtrlsForm) 678 | m.CtrlsForm.DPIAwareSaveOriginalInfo(m.Ctrl) 679 | ENDIF 680 | 681 | * the _Screen manages the control 682 | CASE m.Ctrl.DPIAwareSelfControl == 3 683 | 684 | _Screen.DPIAwareScreenManager.DPIAwareSaveOriginalInfo(m.Ctrl) 685 | 686 | ENDCASE 687 | CATCH && ignore any errors, the method may not have been implemented 688 | ENDTRY 689 | 690 | ENDIF 691 | 692 | ENDFUNC 693 | 694 | * SaveGraphicAlternatives 695 | * Identifies and saves the alternate graphic properties (Picture, PictureVal, and Icon). 696 | * Alternative graphics are set at design time in properties to which a DPI scale has been added. 697 | * For instance, Picture100, Picture125, and Picture150 serve as alternatives to the Picture property 698 | * when the DPI scale is 100, 125, and 150 or above. 699 | FUNCTION SaveGraphicAlternatives (Ctrl AS Object, Property AS String) 700 | 701 | LOCAL AlternativesList AS String 702 | LOCAL AlternativeLevel AS String 703 | LOCAL ARRAY Properties[1] 704 | LOCAL PropertyIndex AS Integer 705 | LOCAL PropertyCheck AS String 706 | LOCAL PropertyCheckLen AS Integer 707 | LOCAL Property100 AS Logical 708 | LOCAL Level100 AS String 709 | 710 | IF !PEMSTATUS(m.Ctrl, m.Property, 5) 711 | RETURN 712 | ENDIF 713 | 714 | m.AlternativesList = "" 715 | m.PropertyCheck = UPPER(m.Property) 716 | m.PropertyCheckLen = LEN(m.PropertyCheck) 717 | m.Property100 = .F. 718 | m.Level100 = "100" 719 | 720 | * look for all alternatives and create a comma separated list 721 | FOR m.PropertyIndex = 1 TO AMEMBERS(m.Properties, m.Ctrl, 0) 722 | IF LEFT(m.Properties[m.PropertyIndex], m.PropertyCheckLen) == m.PropertyCheck 723 | m.AlternativeLevel = SUBSTR(m.Properties[m.PropertyIndex], m.PropertyCheckLen + 1) 724 | IF m.AlternativeLevel == LTRIM(STR(VAL(m.AlternativeLevel))) AND VAL(m.AlternativeLevel) >= DPI_STANDARD_SCALE 725 | m.AlternativesList = m.AlternativesList + IIF(EMPTY(m.AlternativesList), "", ",") + m.AlternativeLevel 726 | IF !m.Property100 727 | m.Property100 = m.AlternativeLevel == m.Level100 728 | ENDIF 729 | ENDIF 730 | ENDIF 731 | ENDFOR 732 | 733 | * if a list was found, store it in a new object property 734 | IF !EMPTY(m.AlternativesList) 735 | * but first make sure there is a version of the graphical alternative for the 100% scale 736 | * if it was not set explicitly at design time 737 | IF !m.Property100 738 | This.AddDPIProperty(m.Ctrl, m.Property + m.Level100, EVALUATE("m.Ctrl." + m.Property)) 739 | m.AlternativesList = m.AlternativesList + "," + m.Level100 740 | ENDIF 741 | This.AddDPIProperty(m.Ctrl, "DPIAlternative_" + m.Property, m.AlternativesList) 742 | ENDIF 743 | 744 | ENDFUNC 745 | 746 | **************************************************************************************** 747 | #DEFINE METHODS_SCALE_FORMS_AND_CONTROLS 748 | **************************************************************************************** 749 | 750 | * Scale 751 | * Scale a container from one scale to another. 752 | FUNCTION Scale (Ctnr AS Object, DPIScale AS Number, DPINewScale AS Number, SkipPreAdjust AS Logical) 753 | 754 | LOCAL IsForm AS Logical 755 | LOCAL SubCtrl AS Object 756 | LOCAL Scalable AS Logical 757 | LOCAL AlternativeFont AS DPIAwareAlternativeFont 758 | 759 | * prepare font name alternatives for a new scale 760 | * aternatives will persist until a new scale is set 761 | IF m.DPINewScale != This.AlternativeFontNamesScale 762 | FOR EACH m.AlternativeFont IN This.AlternativeFontNames 763 | m.AlternativeFont.FindAlternative(m.DPINewScale) 764 | ENDFOR 765 | This.AlternativeFontNamesScale = m.DPINewScale 766 | ENDIF 767 | 768 | m.IsForm = m.Ctnr.BaseClass == 'Form' 769 | IF m.IsForm 770 | m.Ctnr.DPIScaling = .T. 771 | This.SetAnchor(m.Ctnr, .T.) 772 | ENDIF 773 | 774 | * forms require a pre-adjustement because of the way Windows/VFP(?) pass from one scale to another, 775 | * removing a few fixed pixels from the form dimensions (width and height) - this is done automatically as soon 776 | * as the DPI scales changes and before the DPIAwareManager has a chance to step in 777 | IF m.IsForm AND ! m.SkipPreAdjust 778 | This.PreAdjustFormDimensions(m.Ctnr, m.DPIScale, m.DPINewScale) 779 | ENDIF 780 | 781 | * if the container is not DPI aware or if it's fully self-controlled, don't touch it 782 | TRY 783 | m.Scalable = NVL(m.Ctnr.DPIAware, .F.) 784 | IF m.Scalable 785 | m.Scalable = This.SelfScaleControl(m.Ctnr, m.DPIScale, m.DPINewScale) 786 | ENDIF 787 | CATCH 788 | m.Scalable = .F. 789 | ENDTRY 790 | 791 | IF !m.Scalable 792 | IF m.IsForm 793 | This.SetAnchor(m.Ctnr, .F.) 794 | m.Ctnr.DPIScaling = .F. 795 | ENDIF 796 | RETURN 797 | ENDIF 798 | 799 | * all anchors in a form are set to zero, so that the scale won't trigger the resizing and repositioning of contained controls 800 | IF m.IsForm 801 | 802 | m.Ctnr.LockScreen = .T. 803 | 804 | * perform the actual resizing of the form 805 | This.AdjustSize(m.Ctnr, m.DPIScale, m.DPINewScale) 806 | 807 | ENDIF 808 | 809 | * do the resizing for all contained controls 810 | FOR EACH m.SubCtrl IN m.Ctnr.Controls 811 | This.ScaleControl(m.SubCtrl, m.DPIScale, m.DPINewScale) 812 | ENDFOR 813 | 814 | * when a form is finished, get back all anchors 815 | IF m.IsForm 816 | 817 | This.SetAnchor(m.Ctnr, .F.) 818 | m.Ctnr.DPIScaling = .F. 819 | m.Ctnr.LockScreen = .F. 820 | 821 | ENDIF 822 | 823 | ENDFUNC 824 | 825 | * ScaleControl 826 | * Scales a control from one scale to another. 827 | FUNCTION ScaleControl (Ctrl AS Object, DPIScale as Number, DPINewScale as Number) 828 | 829 | LOCAL Scalable AS Logical 830 | LOCAL AutoSizeCtrl AS Logical 831 | 832 | * If the control is not DPI aware or if it is fully self-controlled, don't touch it 833 | TRY 834 | m.Scalable = NVL(m.Ctrl.DPIAware, .F.) 835 | IF m.Scalable 836 | m.Scalable = This.SelfScaleControl(m.Ctrl, m.DPIScale, m.DPINewScale) 837 | ENDIF 838 | CATCH 839 | m.Scalable = .F. 840 | ENDTRY 841 | 842 | IF !m.Scalable 843 | RETURN 844 | ENDIF 845 | 846 | LOCAL SubCtrl AS Object 847 | 848 | IF PEMSTATUS(m.Ctrl, "AutoSize", 5) 849 | m.AutoSizeCtrl = m.Ctrl.AutoSize 850 | m.Ctrl.AutoSize = .F. 851 | ELSE 852 | m.AutoSizeCtrl = .F. 853 | ENDIF 854 | 855 | IF !m.Ctrl.BaseClass $ 'Custom,Timer' 856 | This.AdjustSize(m.Ctrl, m.DPIScale, m.DPINewScale) 857 | ENDIF 858 | 859 | DO CASE 860 | CASE m.Ctrl.BaseClass == 'Container' 861 | 862 | This.Scale(m.Ctrl, m.DPIScale, m.DPINewScale) 863 | 864 | CASE m.Ctrl.BaseClass == 'Pageframe' 865 | 866 | * the pageframe is already scaled, but scaling pages may still affect the pageframe size 867 | LOCAL TabSize AS Number, NewTabSize AS Number 868 | m.TabSize = 0 869 | WITH m.Ctrl AS PageFrame 870 | * if the pageframe has tabs, get their current size before being scaled by the Pages 871 | IF .Tabs 872 | IF BITAND(.TabOrientation, 0x02) != 0 873 | m.TabSize = .Width - .PageWidth 874 | ELSE 875 | m.TabSize = .Height - .PageHeight 876 | ENDIF 877 | ENDIF 878 | ENDWITH 879 | 880 | FOR EACH m.SubCtrl AS Page IN m.Ctrl.Pages 881 | This.AdjustSize(m.SubCtrl, m.DPIScale, m.DPINewScale) 882 | This.Scale(m.SubCtrl, m.DPIScale, m.DPINewScale) 883 | ENDFOR 884 | 885 | * recover the size of the pageframe by compensating for what the tabs scaling may have added or cut 886 | IF m.TabSize != 0 887 | WITH m.Ctrl AS PageFrame 888 | IF BITAND(.TabOrientation, 0x02) != 0 889 | m.NewTabSize = .Width - .PageWidth 890 | .Width = .Width - (m.NewTabSize - m.TabSize) 891 | ELSE 892 | m.NewTabSize = .Height - .PageHeight 893 | .Height = .Height - (m.NewTabSize - m.TabSize) 894 | ENDIF 895 | ENDWITH 896 | ENDIF 897 | 898 | CASE m.Ctrl.BaseClass == 'Grid' 899 | 900 | * for a grid, calculate the weight of the fixed size elements 901 | LOCAL FixedWeight AS Number, FutureWidth AS Number 902 | m.FixedWeight = 0 903 | WITH m.Ctrl AS Grid 904 | IF .RecordMark 905 | m.FixedWeight = 10 906 | ENDIF 907 | IF .DeleteMark 908 | m.FixedWeight = m.FixedWeight + 8 909 | ENDIF 910 | IF BITAND(.ScrollBars, 0x02) != 0 911 | m.FixedWeight = m.FixedWeight + SYSMETRIC(5) + 1 912 | ENDIF 913 | m.FixedWeight = m.FixedWeight + .ColumnCount * .GridLineWidth + 2 && grid's border width 914 | 915 | * calculate how the fixed size elements impact the size of the columns 916 | * growing will add extra size (as a proportion) to each column 917 | m.FutureWidth = ROUND(.Width / This.GetXYRatio(m.DPIScale) * This.GetXYRatio(m.DPINewScale), 0) 918 | m.FixedWeight = (m.FutureWidth - m.FixedWeight) / (.Width - m.FixedWeight) - (m.DPINewScale / m.DPIScale) 919 | 920 | ENDWITH 921 | 922 | FOR EACH m.SubCtrl AS Column IN m.Ctrl.Columns 923 | * the column will have extra plus or minus space, since some components of the grid width do not scale 924 | This.AdjustSize(m.SubCtrl, m.DPIScale, m.DPINewScale, m.FixedWeight) 925 | This.Scale(m.SubCtrl, m.DPIScale, m.DPINewScale) 926 | ENDFOR 927 | 928 | CASE m.Ctrl.BaseClass $ 'Commandgroup,Optiongroup' 929 | 930 | FOR EACH m.SubCtrl In m.Ctrl.Buttons 931 | This.AdjustSize(m.SubCtrl, m.DPIScale, m.DPINewScale) 932 | ENDFOR 933 | 934 | ENDCASE 935 | 936 | IF m.AutoSizeCtrl 937 | m.Ctrl.AutoSize = .T. 938 | ENDIF 939 | 940 | ENDFUNC 941 | 942 | * SelfScaleControl 943 | * Checks if the scale of the control is processed by the control itself. 944 | * If it returns .T., the manager will continue for the control; if .F., stops the scale process for the container. 945 | FUNCTION SelfScaleControl (Ctrl AS Object, DPIScale AS Integer, DPINewScale AS Integer) AS Logical 946 | 947 | LOCAL CtrlsForm AS Form 948 | 949 | * if DPI awareness is controlled by the container itself, just pass the process to the container 950 | IF PEMSTATUS(m.Ctrl, "DPIAwareSelfControl", 5) 951 | 952 | DO CASE 953 | 954 | * the scale process is made by the control itself 955 | CASE m.Ctrl.DPIAwareSelfControl = 1 956 | 957 | RETURN m.Ctrl.DPIAwareSelfManager(m.DPIScale, m.DPINewScale) 958 | 959 | * the scale process is made by the form 960 | CASE m.Ctrl.DPIAwareSelfControl = 2 961 | 962 | m.CtrlsForm = This.GetThisform(m.Ctrl) 963 | IF !ISNULL(m.CtrlsForm) 964 | RETURN m.CtrlsForm.DPIAwareControlsManager(m.DPIScale, m.DPINewScale, m.Ctrl) 965 | ENDIF 966 | 967 | * the scale process is made by the _Screen 968 | CASE m.Ctrl.DPIAwareSelfControl = 3 969 | 970 | RETURN _Screen.DPIAwareScreenManager.DPIAwareControlsManager(m.DPIScale, m.DPINewScale, m.Ctrl) 971 | 972 | ENDCASE 973 | 974 | ENDIF 975 | 976 | * the DPI manager process the control 977 | RETURN .T. 978 | 979 | ENDFUNC 980 | 981 | * SetAnchor 982 | * Sets or unsets (sets to zero) the property Anchor of a container and of its contained controls. 983 | FUNCTION SetAnchor (Cntr AS Object, Unset AS Logical) 984 | 985 | LOCAL SubCtrl AS Object 986 | 987 | FOR EACH m.SubCtrl IN m.Cntr.Controls 988 | This.SetAnchorControl(m.SubCtrl, m.Unset) 989 | ENDFOR 990 | 991 | ENDFUNC 992 | 993 | * SetAnchorControl 994 | * Sets or unsets (sets to zero) the property Anchor of a control. 995 | FUNCTION SetAnchorControl (Ctrl AS Object, Unset AS Logical) 996 | 997 | LOCAL SubCtrl AS Object 998 | 999 | TRY 1000 | m.Ctrl.Anchor = IIF(m.Unset, 0, m.Ctrl.DPIAWare_Anchor) 1001 | CATCH 1002 | ENDTRY 1003 | 1004 | DO CASE 1005 | CASE m.Ctrl.BaseClass == 'Container' 1006 | 1007 | This.SetAnchor(m.Ctrl, m.Unset) 1008 | 1009 | CASE m.Ctrl.BaseClass == 'Pageframe' 1010 | 1011 | FOR EACH m.SubCtrl AS Page IN m.Ctrl.Pages 1012 | This.SetAnchor(m.SubCtrl, m.Unset) 1013 | ENDFOR 1014 | 1015 | CASE m.Ctrl.BaseClass == 'Grid' 1016 | 1017 | FOR EACH m.SubCtrl AS Column IN m.Ctrl.Columns 1018 | This.SetAnchor(m.SubCtrl, m.Unset) 1019 | ENDFOR 1020 | 1021 | CASE m.Ctrl.BaseClass $ 'Commandgroup,Optiongroup' 1022 | 1023 | FOR EACH m.SubCtrl IN m.Ctrl.Buttons 1024 | This.SetAnchorControl(m.SubCtrl, m.Unset) 1025 | ENDFOR 1026 | 1027 | ENDCASE 1028 | 1029 | ENDFUNC 1030 | 1031 | * PreAdjustFormDimensions 1032 | * Pre-adjusts form dimensions (width and height) - Windows (and/or VFP?) seems to cut a fixed amount of 1033 | * pixels when moving from one scale to the other. 1034 | FUNCTION PreAdjustFormDimensions (Ctrl AS Form, DPIScale AS Number, NewDPIScale AS Number) 1035 | 1036 | * but only for top-level forms or non-sizeable forms 1037 | IF (m.Ctrl.ShowWindow == 2 OR m.Ctrl == _Screen) OR m.Ctrl.BorderStyle != 3 1038 | 1039 | LOCAL Scale AS Integer 1040 | LOCAL WidthAdjustment AS Integer 1041 | LOCAL HeightAdjustment AS Integer 1042 | 1043 | * scale level: 0 = 100, 1 = 125, 2 = 150, etc. 1044 | m.Scale = This.GetDPILevel(m.NewDPIScale) 1045 | m.WidthAdjustment = VAL(GETWORDNUM(This.WidthAdjustments, m.Scale, ",")) 1046 | m.HeightAdjustment = VAL(GETWORDNUM(This.HeightAdjustments, m.Scale, ",")) 1047 | 1048 | * add the adjustments to the cutted dimensions, to compensate for the cutting 1049 | m.Ctrl.Width = m.Ctrl.Width + m.WidthAdjustment 1050 | m.Ctrl.Height = m.Ctrl.Height + m.HeightAdjustment 1051 | 1052 | m.Scale = This.GetDPILevel(m.DPIScale) 1053 | m.WidthAdjustment = VAL(GETWORDNUM(This.WidthAdjustments, m.Scale, ",")) 1054 | m.HeightAdjustment = VAL(GETWORDNUM(This.HeightAdjustments, m.Scale, ",")) 1055 | 1056 | * but remove the adjustments made previously 1057 | m.Ctrl.Width = m.Ctrl.Width - m.WidthAdjustment 1058 | m.Ctrl.Height = m.Ctrl.Height - m.HeightAdjustment 1059 | 1060 | ENDIF 1061 | 1062 | ENDFUNC 1063 | 1064 | **************************************************************************************** 1065 | #DEFINE METHODS_ADJUST_DIMENSION_AND_PROPERTIES_TO_NEW_SCALE 1066 | **************************************************************************************** 1067 | 1068 | * AdjustSize 1069 | * Adjusts the size and position of a control from a scale to another. 1070 | Function AdjustSize (Ctrl AS Object, DPIScale as Number, NewDPIScale AS Number, ExtraWidthRatio AS Number) 1071 | 1072 | LOCAL IsForm AS Logical 1073 | 1074 | LOCAL XYRatio AS Number, NewXYRatio AS Number 1075 | 1076 | LOCAL IsGrowing AS Logical 1077 | 1078 | * XY ratios are the multipliers for both scales 1079 | m.XYRatio = This.GetXYRatio(m.DPIScale) 1080 | m.NewXYRatio = This.GetXYRatio(m.NewDPIScale) 1081 | 1082 | * how are we growing? 1083 | m.IsGrowing = m.DPIScale < m.NewDPIScale 1084 | 1085 | m.IsForm = m.Ctrl.BaseClass == "Form" 1086 | 1087 | IF ! m.Ctrl.BaseClass == "Grid" 1088 | * if we are not growing, calculate the margin and border first to arrange more space for the text 1089 | IF !m.IsGrowing 1090 | This.AdjustFixedPropertyValue(m.Ctrl, "Margin", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1091 | This.AdjustFixedPropertyValue(m.Ctrl, "PictureMargin", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1092 | This.AdjustFixedPropertyValue(m.Ctrl, "PictureSpacing", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1093 | This.AdjustFixedPropertyValue(m.Ctrl, "BorderWidth", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1094 | ENDIF 1095 | * adjust the font name before adjusting its size 1096 | This.AdjustFontNameAlternative(m.Ctrl) 1097 | * adjust font size always from its original setting (hence, taken as a "fixed" property) 1098 | This.AdjustFixedPropertyValue(m.Ctrl, "FontSize", m.XYRatio, m.NewXYRatio) 1099 | * if it is growing, margins are arranged afterward 1100 | IF m.IsGrowing 1101 | This.AdjustFixedPropertyValue(m.Ctrl, "BorderWidth", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1102 | This.AdjustFixedPropertyValue(m.Ctrl, "PictureSpacing", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1103 | This.AdjustFixedPropertyValue(m.Ctrl, "PictureMargin", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1104 | This.AdjustFixedPropertyValue(m.Ctrl, "Margin", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1105 | ENDIF 1106 | ELSE 1107 | * grids: 1108 | * row height and header height, unless they're marked as Auto 1109 | This.AdjustPropertyValue(m.Ctrl, "RowHeight", m.XYRatio, m.NewXYRatio, -1) 1110 | This.AdjustPropertyValue(m.Ctrl, "HeaderHeight", m.XYRatio, m.NewXYRatio, -1) 1111 | * other properties 1112 | This.AdjustFixedPropertyValue(m.Ctrl, "Partition", m.XYRatio, m.NewXYRatio, 0) 1113 | This.AdjustFixedPropertyValue(m.Ctrl, "GridLineWidth", m.XYRatio, m.NewXYRatio) 1114 | ENDIF 1115 | 1116 | * if we are growing, make sure we grow maximum dimensions before growing 1117 | IF m.IsGrowing 1118 | This.AdjustFixedPropertyValue(m.Ctrl, "MaxWidth", m.XYRatio, m.NewXYRatio, -1) 1119 | This.AdjustFixedPropertyValue(m.Ctrl, "MaxHeight", m.XYRatio, m.NewXYRatio, -1) 1120 | IF PCOUNT() < 4 1121 | This.AdjustPropertyValue(m.Ctrl, "Width", m.XYRatio, m.NewXYRatio) 1122 | ELSE 1123 | This.AdjustPropertyValue(m.Ctrl, "Width", m.XYRatio, m.NewXYRatio, .NULL., m.ExtraWidthRatio) 1124 | ENDIF 1125 | This.AdjustPropertyValue(m.Ctrl, "Height", m.XYRatio, m.NewXYRatio) 1126 | This.AdjustFixedPropertyValue(m.Ctrl, "MinWidth", m.XYRatio, m.NewXYRatio, -1) 1127 | This.AdjustFixedPropertyValue(m.Ctrl, "MinHeight", m.XYRatio, m.NewXYRatio, -1) 1128 | * or the other way around, if shrinking 1129 | ELSE 1130 | This.AdjustFixedPropertyValue(m.Ctrl, "MinWidth", m.XYRatio, m.NewXYRatio, -1) 1131 | This.AdjustFixedPropertyValue(m.Ctrl, "MinHeight", m.XYRatio, m.NewXYRatio, -1) 1132 | IF PCOUNT() < 4 1133 | This.AdjustPropertyValue(m.Ctrl, "Width", m.XYRatio, m.NewXYRatio) 1134 | ELSE 1135 | This.AdjustPropertyValue(m.Ctrl, "Width", m.XYRatio, M.NewXYRatio, .NULL., m.ExtraWidthRatio) 1136 | ENDIF 1137 | This.AdjustPropertyValue(m.Ctrl, "Height", m.XYRatio, m.NewXYRatio) 1138 | This.AdjustFixedPropertyValue(m.Ctrl, "MaxWidth", m.XYRatio, m.NewXYRatio, -1) 1139 | This.AdjustFixedPropertyValue(m.Ctrl, "MaxHeight", m.XYRatio, m.NewXYRatio, -1) 1140 | ENDIF 1141 | 1142 | * for all controls except forms, deal with their position 1143 | IF ! m.IsForm 1144 | This.AdjustPropertyValue(m.Ctrl, "Top", m.XYRatio, m.NewXYRatio) 1145 | This.AdjustPropertyValue(m.Ctrl, "Left", m.XYRatio, m.NewXYRatio) 1146 | ENDIF 1147 | 1148 | * process other positional or dimensional properties 1149 | This.AdjustFixedPropertyValue(m.Ctrl, "DrawWidth", m.XYRatio, m.NewXYRatio, .NULL., .T.) 1150 | This.AdjustFixedPropertyValue(m.Ctrl, "ColumnWidths", m.XYRatio, m.NewXYRatio) 1151 | 1152 | * take care of the alternate graphics the control may have defined for the new scale 1153 | This.AdjustGraphicAlternatives(m.Ctrl, m.NewDPIScale) 1154 | 1155 | * reset the form's icon 1156 | IF m.IsForm 1157 | This.ResetIcon(m.Ctrl) 1158 | ENDIF 1159 | 1160 | ENDFUNC 1161 | 1162 | * AdjustPropertyValue 1163 | * Adjusts the current value of a property to a new value. 1164 | FUNCTION AdjustPropertyValue (Ctrl AS Object, Property AS String, Ratio AS Number, NewRatio AS Number, Excluded AS Number, ExtraRatio AS Number) AS Logical 1165 | 1166 | LOCAL CtrlProperty AS String 1167 | LOCAL Adjusted AS Logical 1168 | LOCAL OriginalValue AS Number 1169 | LOCAL CurrentValue AS Number 1170 | LOCAL NewCurrentValue AS Number 1171 | LOCAL NewAdjustedRatio AS Number 1172 | 1173 | m.Adjusted = .F. 1174 | 1175 | IF PEMSTATUS(m.Ctrl, "DPIAware_" + m.Property, 5) 1176 | TRY 1177 | * regular properties are scaled from the current value 1178 | * unless they are excluded for being automatic or unset 1179 | m.OriginalValue = EVALUATE("m.Ctrl.DPIAware_" + m.Property) 1180 | IF PCOUNT() < 5 OR ISNULL(m.Excluded) OR m.Excluded != m.OriginalValue 1181 | 1182 | * get the current value, stored in the property, and calculate the new one for a new scale 1183 | m.CtrlProperty = "m.Ctrl." + m.Property 1184 | m.CurrentValue = EVALUATE(m.CtrlProperty) 1185 | IF PCOUNT() < 6 1186 | m.NewAdjustedRatio = m.NewRatio 1187 | ELSE 1188 | m.NewAdjustedRatio = m.NewRatio + m.ExtraRatio 1189 | ENDIF 1190 | m.NewCurrentValue = m.CurrentValue / m.Ratio * m.NewAdjustedRatio 1191 | 1192 | * store the final (rounded) value 1193 | STORE ROUND(m.NewCurrentValue, 0) TO (m.CtrlProperty) 1194 | 1195 | m.Adjusted = .T. 1196 | 1197 | * log the adjustment 1198 | IF This.Logging 1199 | This.Log(m.Ctrl.Name, m.Ctrl.Class, m.Property, TRANSFORM(m.OriginalValue), m.Ratio, m.NewAdjustedRatio, .F., ; 1200 | TRANSFORM(m.CurrentValue), TRANSFORM(m.NewCurrentValue), TRANSFORM(EVALUATE(m.CtrlProperty))) 1201 | ENDIF 1202 | 1203 | ENDIF 1204 | CATCH 1205 | ENDTRY 1206 | ENDIF 1207 | 1208 | RETURN m.Adjusted 1209 | 1210 | ENDFUNC 1211 | 1212 | * AdjustFixedPropertyValue 1213 | * Adjusts the original value of a property to a new value. 1214 | FUNCTION AdjustFixedPropertyValue (Ctrl AS Object, Property AS String, Ratio AS Number, NewRatio AS Number, Excluded AS Number, Low AS Logical) AS Logical 1215 | 1216 | LOCAL CtrlProperty AS String 1217 | LOCAL Adjusted AS Logical 1218 | LOCAL OriginalValue AS NumberOrString 1219 | LOCAL NewCurrentValue AS NumberOrString 1220 | LOCAL ARRAY ValuesList[1] 1221 | LOCAL ValueIndex AS Integer 1222 | LOCAL MemberValue AS Number 1223 | 1224 | m.Adjusted = .F. 1225 | 1226 | IF PEMSTATUS(m.Ctrl, "DPIAware_" + m.Property, 5) 1227 | TRY 1228 | 1229 | * fixed properties are scaled from the original value 1230 | * unless they are excluded for being automatic or unset 1231 | m.OriginalValue = EVALUATE("m.Ctrl.DPIAware_" + m.Property) 1232 | IF PCOUNT() < 5 OR ISNULL(m.Excluded) OR m.Excluded != m.OriginalValue 1233 | 1234 | * the destination of the new value 1235 | m.CtrlProperty = "m.Ctrl." + m.Property 1236 | 1237 | * for most cases, properties are numeric 1238 | IF VARTYPE(m.OriginalValue) == "N" 1239 | 1240 | * calculate the new value 1241 | m.NewCurrentValue = m.OriginalValue * m.NewRatio 1242 | 1243 | * store the final (rounded or truncated) value 1244 | IF !m.Low 1245 | STORE ROUND(m.NewCurrentValue, 0) TO (m.CtrlProperty) 1246 | ELSE 1247 | STORE FLOOR(m.NewCurrentValue) TO (m.CtrlProperty) 1248 | ENDIF 1249 | 1250 | * string properties consist in a comma-separated list of numbers 1251 | ELSE 1252 | 1253 | * prepare to rebuild the list 1254 | m.NewCurrentValue = "" 1255 | 1256 | * adjust every member of the list 1257 | FOR m.ValueIndex = 1 TO ALINES(m.ValuesList, m.OriginalValue, 0, ",") 1258 | 1259 | m.MemberValue = VAL(m.ValuesList[m.ValueIndex]) * m.NewRatio 1260 | 1261 | IF m.Low 1262 | m.NewCurrentValue = m.NewCurrentValue + LTRIM(STR(FLOOR(m.MemberValue))) + "," 1263 | ELSE 1264 | m.NewCurrentValue = m.NewCurrentValue + LTRIM(STR(ROUND(m.MemberValue, 0))) + "," 1265 | ENDIF 1266 | 1267 | ENDFOR 1268 | 1269 | * store the list with new values 1270 | m.NewCurrentValue = RTRIM(m.NewCurrentValue, 0, ",") 1271 | STORE m.NewCurrentValue TO (m.CtrlProperty) 1272 | 1273 | ENDIF 1274 | 1275 | m.Adjusted = .T. 1276 | 1277 | * log the adjustment 1278 | IF This.Logging 1279 | This.Log(m.Ctrl.Name, m.Ctrl.Class, m.Property, TRANSFORM(m.OriginalValue), m.Ratio, m.NewAdjustedRatio, .F., ; 1280 | TRANSFORM(m.CurrentValue), TRANSFORM(m.NewCurrentValue), TRANSFORM(EVALUATE(m.CtrlProperty))) 1281 | ENDIF 1282 | 1283 | ENDIF 1284 | CATCH 1285 | ENDTRY 1286 | ENDIF 1287 | 1288 | RETURN m.Adjusted 1289 | 1290 | ENDFUNC 1291 | 1292 | * AdjustFontNameAlternative 1293 | * Adjusts the name of a font by using the appropriate alternative 1294 | FUNCTION AdjustFontNameAlternative (Ctrl AS Object) 1295 | 1296 | LOCAL AlternativeFontName AS String 1297 | LOCAL FontNameKey AS String 1298 | LOCAL FontIndex AS Integer 1299 | 1300 | IF PEMSTATUS(m.Ctrl, "DPIAware_FontName", 5) 1301 | m.FontNameKey = UPPER(m.Ctrl.DPIAware_FontName) 1302 | m.FontIndex = 0 1303 | * use the original font name to locate the current alternative 1304 | * try to locate the best alternative for the font style 1305 | TRY 1306 | IF m.Ctrl.FontBold AND m.Ctrl.FontItalic 1307 | m.FontIndex = This.AlternativeFontNames.GetKey(m.FontNameKey + ",BI") 1308 | ENDIF 1309 | IF m.FontIndex == 0 AND m.Ctrl.FontBold 1310 | m.FontIndex = This.AlternativeFontNames.GetKey(m.FontNameKey + ",B") 1311 | ENDIF 1312 | IF m.FontIndex == 0 AND m.Ctrl.FontItalic 1313 | m.FontIndex = This.AlternativeFontNames.GetKey(m.FontNameKey + ",I") 1314 | ENDIF 1315 | IF m.FontIndex == 0 AND !m.Ctrl.FontBold AND !m.Ctrl.FontItalic 1316 | m.FontIndex = This.AlternativeFontNames.GetKey(m.FontNameKey + ",N") 1317 | ENDIF 1318 | CATCH 1319 | ENDTRY 1320 | * try an unstyled alternative, if a styled one was not found 1321 | m.FontIndex = EVL(m.FontIndex, This.AlternativeFontNames.GetKey(m.FontNameKey)) 1322 | * if it exists 1323 | IF m.FontIndex != 0 1324 | TRY 1325 | * set it, if needed 1326 | m.AlternativeFontName = This.AlternativeFontNames.Item(m.FontIndex).AlternativeFontName 1327 | IF ! m.Ctrl.FontName == m.AlternativeFontName 1328 | m.Ctrl.FontName = m.AlternativeFontName 1329 | ENDIF 1330 | CATCH 1331 | ENDTRY 1332 | ENDIF 1333 | ENDIF 1334 | 1335 | ENDFUNC 1336 | 1337 | * AdjustGraphicAlternatives 1338 | * Adjusts the value of graphic properties by selecting an appropriate alternative. 1339 | FUNCTION AdjustGraphicAlternatives (Ctrl AS Object, NewDPIScale AS Number) 1340 | 1341 | This.FindGraphicAlternative(m.Ctrl, "Picture", m.NewDPIScale) 1342 | This.FindGraphicAlternative(m.Ctrl, "PictureVal", m.NewDPIScale) 1343 | This.FindGraphicAlternative(m.Ctrl, "Icon", m.NewDPIScale) 1344 | This.FindGraphicAlternative(m.Ctrl, "MouseIcon", m.NewDPIScale) 1345 | This.FindGraphicAlternative(m.Ctrl, "DragIcon", m.NewDPIScale) 1346 | This.FindGraphicAlternative(m.Ctrl, "DisabledPicture", m.NewDPIScale) 1347 | This.FindGraphicAlternative(m.Ctrl, "DownPicture", m.NewDPIScale) 1348 | 1349 | ENDFUNC 1350 | 1351 | * FindGraphicAlternative 1352 | * Finds a best alternative graphic for the new scale. 1353 | FUNCTION FindGraphicAlternative (Ctrl AS Object, Property AS String, DPIScale AS Number) 1354 | 1355 | LOCAL CtrlProperty AS String 1356 | LOCAL Alternatives AS String 1357 | LOCAL ARRAY AlternativeScales[1] 1358 | LOCAL AlternativesIndex AS Integer 1359 | LOCAL BestAlternative AS String 1360 | LOCAL BestDifference AS Integer, Difference AS Integer 1361 | 1362 | * if there isn't an alternative list, quit looking into it 1363 | m.Alternatives = "DPIAlternative_" + m.Property 1364 | IF !PEMSTATUS(m.Ctrl, m.Alternatives, 5) 1365 | RETURN 1366 | ENDIF 1367 | 1368 | m.CtrlProperty = "m.Ctrl." + m.Property 1369 | BestDifference = -1 1370 | BestAlternative = "" 1371 | 1372 | * go through the list of scales for which there is an alternative 1373 | FOR m.AlternativesIndex = 1 TO ALINES(m.AlternativeScales, EVALUATE("m.Ctrl." + m.Alternatives), 0, ",") 1374 | 1375 | * calculate the difference for the new scale 1376 | m.Difference = VAL(m.AlternativeScales[m.AlternativesIndex]) - m.DPIScale 1377 | 1378 | * there is a match! get the value in the alternate graphic property and stop searching 1379 | IF m.Difference = 0 1380 | m.BestAlternative = EVALUATE(m.CtrlProperty + m.AlternativeScales[m.AlternativesIndex]) 1381 | EXIT 1382 | ENDIF 1383 | 1384 | * but if not and this one was the best yet, use it and continue looking 1385 | IF m.Difference > 0 AND (m.BestDifference < 0 OR m.Difference < m.BestDifference) 1386 | m.BestAlternative = EVALUATE(m.CtrlProperty + m.AlternativeScales[m.AlternativesIndex]) 1387 | m.BestDifference = m.Difference 1388 | ENDIF 1389 | ENDFOR 1390 | 1391 | * if we found an alternative, that will be the new value for the property 1392 | IF !EMPTY(m.BestAlternative) 1393 | STORE m.BestAlternative TO (m.CtrlProperty) 1394 | ENDIF 1395 | 1396 | ENDFUNC 1397 | 1398 | * ResetIcon 1399 | * Reset the icon for (hopefully) better quality 1400 | FUNCTION ResetIcon (Ctrl AS Object) 1401 | 1402 | LOCAL SafetyStatus AS String 1403 | LOCAL IconFile AS String 1404 | LOCAL hIcon AS Integer 1405 | 1406 | * only for Forms 1407 | IF !m.Ctrl.BaseClass == "Form" OR EMPTY(m.Ctrl.Icon) 1408 | RETURN 1409 | ENDIF 1410 | 1411 | m.SafetyStatus = SET("Safety") 1412 | SET SAFETY OFF 1413 | 1414 | * use a temporary file to make sure Windows sees the icon 1415 | m.IconFile = ADDBS(SYS(2023)) + "~dpiawm" + SYS(3) + ".ico" 1416 | TRY 1417 | STRTOFILE(FILETOSTR(m.Ctrl.Icon), m.IconFile) 1418 | CATCH 1419 | m.IconFile = "" 1420 | ENDTRY 1421 | 1422 | IF m.SafetyStatus == "ON" 1423 | SET SAFETY ON 1424 | ENDIF 1425 | 1426 | IF !EMPTY(m.IconFile) 1427 | * success in creating the file? get the icon from the temporary file and reset it 1428 | m.hIcon = dpiaw_ExtractIcon(0, m.IconFile, 0) 1429 | dpiaw_SendMessage(m.Ctrl.hWnd, WM_SETICON, ICON_SMALL, m.hIcon) 1430 | * use it also for the "big" version of top level forms 1431 | IF m.Ctrl == _Screen OR m.Ctrl.ShowWindow == 2 1432 | dpiaw_SendMessage(m.Ctrl.hWnd, WM_SETICON, ICON_BIG, m.hIcon) 1433 | ENDIF 1434 | * clean up 1435 | TRY 1436 | ERASE (m.IconFile) 1437 | CATCH 1438 | ENDTRY 1439 | ENDIF 1440 | 1441 | ENDFUNC 1442 | 1443 | **************************************************************************************** 1444 | #DEFINE METHODS_HELPERS 1445 | **************************************************************************************** 1446 | 1447 | * AddControl 1448 | * Adds a control in run-time (scaled at 96/100%) 1449 | FUNCTION AddControl (NewControl AS Object) 1450 | 1451 | This.SaveControl(m.NewControl) 1452 | This.ScaleControl(m.NewControl, DPI_STANDARD_SCALE, This.GetFormDPIScale(m.NewControl)) 1453 | 1454 | ENDFUNC 1455 | 1456 | **************************************************************************************** 1457 | #DEFINE METHODS_UTILITIES 1458 | **************************************************************************************** 1459 | 1460 | * GetThisform 1461 | * Returns the form to which an object belongs. 1462 | FUNCTION GetThisform (Ctrl AS Object) AS Integer 1463 | 1464 | LOCAL ThisObject AS Object 1465 | 1466 | * look for a form in the (parent) hierarchy of the object 1467 | m.ThisObject = m.Ctrl 1468 | DO WHILE !m.ThisObject.BaseClass == "Form" AND PEMSTATUS(m.ThisObject, "Parent", 5) 1469 | m.ThisObject = m.ThisObject.Parent 1470 | ENDDO 1471 | 1472 | RETURN IIF(m.ThisObject.BaseClass == "Form", m.ThisObject, .NULL.) 1473 | 1474 | ENDFUNC 1475 | 1476 | * AddDPIProperty 1477 | * Adds a DPI-awareness related property to an object (fails silently) 1478 | FUNCTION AddDPIProperty (Ctrl AS Object, Property AS String, InitialValue) AS Void 1479 | 1480 | TRY 1481 | m.Ctrl.AddProperty(m.Property, m.InitialValue) 1482 | CATCH 1483 | ENDTRY 1484 | 1485 | ENDFUNC 1486 | 1487 | * Log 1488 | * Logs a scale operation 1489 | FUNCTION Log (ControlName AS String, ClassName AS String, Property AS String, ; 1490 | Original AS String, Ratio AS Double, NewRatio AS Double, ; 1491 | FixedProperty AS Logical, ; 1492 | ScaledBefore AS String, Calculated AS String, Stored AS String) 1493 | 1494 | ENDFUNC 1495 | 1496 | * GetXYRatio 1497 | * Gets a ratio multiplier, given a scale 1498 | FUNCTION GetXYRatio (Scale AS Integer) AS Number 1499 | 1500 | RETURN m.Scale / DPI_STANDARD_SCALE 1501 | 1502 | ENDFUNC 1503 | 1504 | * GetDPILevel 1505 | * Gets the DPI level (0, 1, 2...) given a scale. 1506 | FUNCTION GetDPILevel (DPIScale AS Integer) AS Integer 1507 | 1508 | RETURN ROUND((m.DPIScale - DPI_STANDARD_SCALE) / DPI_SCALE_INCREMENT, 0) 1509 | 1510 | ENDFUNC 1511 | 1512 | * GetScaledValue 1513 | * Scale a value, given a scale 1514 | FUNCTION GetScaledValue (Unscaled AS Number, Scale AS Integer) AS Number 1515 | 1516 | RETURN m.Unscaled * This.GetXYRatio(m.Scale) 1517 | 1518 | ENDFUNC 1519 | 1520 | * GetUnscaledValue 1521 | * Unscale a value, given a scale 1522 | FUNCTION GetUnscaledValue (Scaled AS Number, Scale AS Integer) AS Number 1523 | 1524 | RETURN m.Scaled / This.GetXYRatio(m.Scale) 1525 | 1526 | ENDFUNC 1527 | 1528 | ENDDEFINE 1529 | 1530 | * DPIAwareAlternativeFont 1531 | * A class to register alternative fonts depending on the scale 1532 | DEFINE CLASS DPIAwareAlternativeFont AS Custom 1533 | 1534 | AlternativeCount = 0 1535 | DIMENSION Scales [1] 1536 | DIMENSION FontNames [1] 1537 | 1538 | AlternativeFontName = "" 1539 | 1540 | FUNCTION Init (BaseFontName AS String) 1541 | 1542 | This.AlternativeCount = 1 1543 | This.Scales[1] = 100 1544 | * discard the style clause to set the base font name 1545 | This.FontNames[1] = LEFT(m.BaseFontName, EVL(RAT(",", m.BaseFontName), LEN(m.BaseFontName) + 1) - 1) 1546 | 1547 | ENDFUNC 1548 | 1549 | FUNCTION AddAlternative (Scale AS Integer, AlternativeFontName AS String) 1550 | 1551 | This.AlternativeCount = This.AlternativeCount + 1 1552 | DIMENSION This.Scales[This.AlternativeCount] 1553 | DIMENSION This.FontNames[This.AlternativeCount] 1554 | This.Scales[This.AlternativeCount] = m.Scale 1555 | This.FontNames[This.AlternativeCount] = m.AlternativeFontName 1556 | 1557 | ENDFUNC 1558 | 1559 | FUNCTION FindAlternative (DPIScale AS Integer) 1560 | 1561 | LOCAL AltIndex AS Integer 1562 | LOCAL BestAlternative AS Integer 1563 | LOCAL Difference AS Integer 1564 | LOCAL BestDifference AS Integer 1565 | 1566 | m.BestAlternative = 1 1567 | m.BestDifference = -1 1568 | 1569 | FOR m.AltIndex = 1 TO This.AlternativeCount 1570 | m.Difference = m.DPIScale - This.Scales[m.AltIndex] 1571 | IF m.Difference == 0 1572 | m.BestAlternative = m.AltIndex 1573 | EXIT 1574 | ENDIF 1575 | IF m.Difference > 0 1576 | IF m.BestDifference == -1 OR m.Difference < m.BestDifference 1577 | m.BestDifference = m.Difference 1578 | m.BestAlternative = m.AltIndex 1579 | ENDIF 1580 | ENDIF 1581 | ENDFOR 1582 | 1583 | This.AlternativeFontName = This.FontNames[m.BestAlternative] 1584 | 1585 | RETURN This.AlternativeFontName 1586 | 1587 | ENDFUNC 1588 | 1589 | ENDDEFINE 1590 | 1591 | 1592 | * DPIAwareScreenManager 1593 | * An extension manager for the _Screen object. 1594 | DEFINE CLASS DPIAwareScreenManager AS Custom 1595 | 1596 | FUNCTION DPIAwareControlsManager(DPIScale AS Integer, DPINewScale AS Integer, Ctrl AS Object) 1597 | RETURN .F. 1598 | ENDFUNC 1599 | 1600 | FUNCTION SelfManage (DPIScale AS Integer, DPINewScale AS Integer) 1601 | RETURN .F. 1602 | ENDFUNC 1603 | 1604 | FUNCTION DPIAwareSaveOriginalInfo (Ctrl AS Object) 1605 | RETURN .T. 1606 | ENDFUNC 1607 | 1608 | ENDDEFINE 1609 | -------------------------------------------------------------------------------- /testing/Fox-64.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/Fox-64.ico -------------------------------------------------------------------------------- /testing/Fox_528px.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/Fox_528px.png -------------------------------------------------------------------------------- /testing/Fox_96px.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/Fox_96px.png -------------------------------------------------------------------------------- /testing/dpi-testing.PJT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/dpi-testing.PJT -------------------------------------------------------------------------------- /testing/dpi-testing.exe.manifest: -------------------------------------------------------------------------------- 1 | 2 | 7 | 13 | DPI testing 14 | 15 | 16 | true/PM 17 | PerMonitorV2, PerMonitor 18 | 19 | 20 | 21 | 22 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /testing/dpi-testing.pjx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/dpi-testing.pjx -------------------------------------------------------------------------------- /testing/dpi-testing.prg: -------------------------------------------------------------------------------- 1 | _Screen.Icon = "Fox-64.ico" 2 | _Screen.Caption = "DPI Testing" 3 | 4 | * CTRL+D on a form displays its dimensions 5 | ON KEY LABEL CTRL+D Dimensions() 6 | 7 | * incorporate FoxyDialog(), by Cesar Chalom 8 | SET PROCEDURE TO FoxyDialog ADDITIVE 9 | 10 | * put the class in scope 11 | DO DPIAwareManager.prg 12 | 13 | * make it public just to let forms put themselves under DPI-aware management 14 | PUBLIC DPI AS DPIAwareManager 15 | 16 | m.DPI = CREATEOBJECT("DPIAwareManager") 17 | * the VFP screen will be managed 18 | m.DPI.Manage(_Screen) 19 | * and we'll want to see a log 20 | m.DPI.Logging = .T. 21 | 22 | CREATE CURSOR DPIAwareManagerLog ; 23 | (PK Int AutoInc, ; 24 | ControlName Varchar(60), ClassName Varchar(60), Property Varchar(32), ; 25 | Original Varchar(254), ; 26 | Ratio Double, NewRatio Double, ; 27 | FixedProperty Logical, ; 28 | ScaledBefore Varchar(254), Calculated Varchar(254), Stored Varchar(254)) 29 | 30 | * create a screen extension manager to demonstrate a DPI-aware menu 31 | _Screen.AddObject("DPIAwareScreenManager", "ScreenManager") 32 | * and use it to hook into the manager logging 33 | BINDEVENT(m.DPI, "Log", _Screen.DPIAwareScreenManager, "LogChange") 34 | 35 | * a new menu pad to extend the system menu 36 | DEFINE PAD padDPIAware OF _MSYSMENU PROMPT "DPIAware" 37 | DEFINE POPUP popDPIAware MARGIN RELATIVE FONT "Segoe UI", 9 38 | ON PAD padDPIAware OF _MSYSMENU ACTIVATE POPUP popDPIAware 39 | DEFINE BAR 1 OF popDPIAware PROMPT "DPI-aware menu bars" 40 | DEFINE BAR 2 OF popDPIAware PROMPT "Current scale: 100%" 41 | 42 | ACTIVATE SCREEN 43 | 44 | * attention! the browse window is not manageable 45 | BROWSE NOWAIT LAST 46 | 47 | * incorporate additional testing in forms and unmanagedforms folders 48 | SET PATH TO forms;unmanagedforms ADDITIVE 49 | 50 | LOCAL ARRAY ManagedForms[2], UnmanagedForms[1] 51 | 52 | * a basic form with info - shown in screen 53 | DO FORM "monitor dpi in screen.scx" NAME m.ManagedForms[1] LINKED NOSHOW 54 | 55 | * manage and display it 56 | m.DPI.Manage(m.ManagedForms[1]) 57 | m.ManagedForms[1].Show() 58 | 59 | * other form to hold information about available displays - shown as top level form 60 | DO FORM "information on displays.scx" NAME m.ManagedForms[2] LINKED NOSHOW 61 | 62 | * as above 63 | m.DPI.Manage(m.ManagedForms[2]) 64 | m.ManagedForms[2].Show() 65 | 66 | ACTIVATE SCREEN 67 | 68 | LOCAL ARRAY SCX[1] 69 | LOCAL NumSCX AS Integer 70 | LOCAL Base AS Integer 71 | LOCAL Term AS Terminator 72 | 73 | m.Base = ALEN(m.ManagedForms) 74 | 75 | m.Term = CREATEOBJECT("Terminator") 76 | 77 | * go through all the test forms in the forms folder 78 | 79 | FOR m.NumSCX = 1 TO ADIR(m.SCX, "forms\*.scx") 80 | 81 | DIMENSION m.ManagedForms[m.NumSCX + m.Base] 82 | 83 | * instantiate the form 84 | DO FORM ("forms\" + m.SCX[m.NumSCX, 1]) NAME m.ManagedForms[m.NumSCX + m.Base] LINKED NOSHOW 85 | 86 | * terminate the test application whem a form is closed 87 | BINDEVENT(m.ManagedForms[m.NumSCX + m.Base], "Destroy", m.Term, "Done") 88 | 89 | * manage and show the form 90 | m.DPI.Manage(m.ManagedForms[m.NumSCX + m.Base]) 91 | m.ManagedForms[m.NumSCX + m.Base].Show() 92 | 93 | ACTIVATE SCREEN 94 | 95 | ENDFOR 96 | 97 | * go through all the unmanaged test forms in the unmanagedforms folder 98 | 99 | FOR m.NumSCX = 1 TO ADIR(m.SCX, "unmanagedforms\*.scx") 100 | 101 | DIMENSION m.UnmanagedForms[m.NumSCX] 102 | 103 | * instantiate the form 104 | DO FORM ("unmanagedforms\" + m.SCX[m.NumSCX, 1]) NAME m.UnmanagedForms[m.NumSCX] LINKED NOSHOW 105 | 106 | * terminate the test application whem a form is closed 107 | BINDEVENT(m.UnmanagedForms[m.NumSCX], "Destroy", m.Term, "Done") 108 | 109 | * show the form, but don't manage it 110 | m.UnmanagedForms[m.NumSCX].Show() 111 | 112 | ACTIVATE SCREEN 113 | 114 | ENDFOR 115 | 116 | * remember how to quit, and display the type of DPI awareness of our application 117 | LOCAL ARRAY AwarenessTypes[4] 118 | m.AwarenessTypes[1] = "PROCESS_DPI_UNAWARE" 119 | m.AwarenessTypes[2] = "PROCESS_SYSTEM_DPI_AWARE" 120 | m.AwarenessTypes[3] = "PROCESS_PER_MONITOR_DPI_AWARE" 121 | m.AwarenessTypes[4] = "UNKNOWN" 122 | 123 | MESSAGEBOX("Close a window to quit!" + 0h0d0d + ; 124 | "Awareness type: " + m.AwarenessTypes[MIN(MAX(m.DPI.AwarenessType, 0), 3) + 1], 64, "DPI-Testing") 125 | 126 | READ EVENTS 127 | 128 | 129 | PROCEDURE Dimensions () 130 | 131 | LOCAL ARRAY ObjInto(1) 132 | LOCAL DF AS Form 133 | 134 | IF AMOUSEOBJ(m.ObjInto, 1) != 0 135 | m.DF = m.ObjInto(2) 136 | MESSAGEBOX(TEXTMERGE("<>: Width = <>, Height = <>")) 137 | ENDIF 138 | 139 | ENDPROC 140 | 141 | DEFINE CLASS Terminator AS Custom 142 | 143 | FUNCTION Done 144 | CLEAR EVENTS 145 | ENDFUNC 146 | 147 | ENDDEFINE 148 | 149 | DEFINE CLASS ScreenManager AS DPIAwareScreenManager OF ../source/dpiawaremanager.prg 150 | 151 | FUNCTION SelfManage (DPIScale AS Integer, DPINewScale AS Integer) 152 | 153 | LOCAL NewFontSize AS Integer 154 | 155 | m.NewFontSize = ROUND(9 * m.DPINewScale / 100, 0) 156 | 157 | DEFINE POPUP popDPIAware MARGIN RELATIVE FONT "Segoe UI", m.NewFontSize 158 | DEFINE BAR 1 OF popDPIAware PROMPT "DPI-aware menu bars" 159 | DEFINE BAR 2 OF popDPIAware PROMPT TEXTMERGE("Current scale: <>%") 160 | 161 | ENDFUNC 162 | 163 | FUNCTION LogChange (ControlName AS String, ClassName AS String, Property AS String, ; 164 | Original AS String, Ratio AS Double, NewRatio AS Double, ; 165 | FixedProperty AS Logical, ; 166 | ScaledBefore AS String, Calculated AS String, Stored AS String) 167 | 168 | INSERT INTO DPIAwareManagerLog (ControlName, ClassName, Property, ; 169 | Original, Ratio, NewRatio, ; 170 | FixedProperty, ; 171 | ScaledBefore, Calculated, Stored) ; 172 | VALUES (m.ControlName, m.ClassName, m.Property, ; 173 | m.Original, m.Ratio, m.NewRatio, ; 174 | m.FixedProperty, ; 175 | m.ScaledBefore, m.Calculated, m.Stored) 176 | 177 | ENDFUNC 178 | 179 | ENDDEFINE 180 | 181 | 182 | -------------------------------------------------------------------------------- /testing/forms/thisFolderIntentionallyLeftEmpty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/forms/thisFolderIntentionallyLeftEmpty -------------------------------------------------------------------------------- /testing/foxydialog.prg: -------------------------------------------------------------------------------- 1 | * File: FOXYDIALOG 2 | * Version 2.41 - 2020-06-13 3 | * by Cesar - VfpImaging 4 | * https://vfpimaging.blogspot.com/2020/05/messagebox-using-simple-vista-task.html 5 | * Displays a Task dialog simple dialog, with custom button captions and icons, and some friendly inputboxes 6 | * 7 | * Usage: 8 | * Function: 9 | * FOXYDIALOG(tcTitle, tcMainInstruction, tcContent, tcnIcon, tcButtons, tnDefault, tnTimeout) 10 | * Parameters: 11 | * - tcTitle - string to be used for the task dialog title. 12 | * - tcMainInstruction - string to be used for the main instruction. 13 | * - tcContent - string used for additional text that appears below the main instruction, in a smaller font. 14 | * - tcnIcon - Character or Integer that identifies the icon to display in the task dialog. 15 | * This parameter can be an integer or some predefined text values, allowing several options. 16 | * If this parameter is EMPTY() or omitted, no icon will be displayed. 17 | * For numeric, the variety of icons is HUGE, all icons stored in the %systemroot%\system32\imageres.dll file. The imageres.dll file contains many icons, used almost everywhere in Windows 10. It has icons for different types of folders, hardware devices, peripherals, actions, and so on. Below in Appendixes 1 and 2 there is a list of the available strings and enumerated icons. In this parameter you can also determine the background color of the dialog main instruction. 18 | * Send a string comma separated, having the desired main icon first, and after the comma a letter representing the background color: R=Red; G=Green; Y=Yellow; S=Silver; B=Blue; Empty() no background, and finally "-" means no left margin. You can also pass a BMP or ICO file - just make sure to have it available on disk, not embedded in your EXE. 19 | * - tcButtons - This parameter determines some important behaviors of the dialog. 20 | * For ordinary dialogs, used for you to pass some information to the users, it specifies the push buttons displayed in the dialog box. A single string containing comma separated captions. If you wish to show a disabled button, add a "\" before the caption. All buttons are Unicode friendly, and you can use some special button captions with special extensions, for the very commonly used buttons - Ok, Cancel, Print, Save, Search. Adding a "#" will add some basic unicode icons. Adding an asterisk - "*" will add some colored icons. 21 | * For INPUTBOXES mode, in the first word of the parameter you can add some special characters as well: 22 | * - "@I" - turns the dialog into a modern INPUTBOX(). 23 | * - "@IU" or "@I!" - the textbox will accept only UPPERCASE characters 24 | * - "@IL" - the textbox will accept only LOWERCASE characters 25 | * "@IN" or "@ID" - numeric (negative and comma accepted) or DIGITS (only integers) 26 | * "@IP" - Password inputbox, shows asterisks for every character 27 | * "@D" - DateBox dialog - showing a cool combobox for date picking 28 | * "@T" - DateTimeBox dialog - showing the same combobox above and a time inputbox 29 | * "@M" - MonthBox dialog - showing a single calendar for date picking 30 | * "@R" - DateRangeBox dialog - showing a double month calendar, allowing users to pick some date ranges 31 | * - tcnDefault 32 | * For DialogBox mode - numeric, specifies the button Id that will be focused. Default = 1 33 | * - For special InputBox mode - specifies the default values shown when the input dialog is shown: Character for "@I" or Date for "@D", "@M", "@R" or DateTime for "@T" tcButtons type 34 | * - tnTimeout - Specifies the number of milliseconds the dialog will be displayed without input from the keyboard or the mouse before clearing itself. You can specify any valid timeout value. A value of less than 1 never times out until user enters input and behaves the same as omitting the nTimeout parameter. The Timeout parameter can be a numeric value or a Character, with the time in milisseconds, and the string that will come together with the time shown. The tag " < SECS > " will be replaced by the time in seconds, with the small unicode clock. Don't miss the samples below. 35 | * Returns: 36 | * For Regular DialogBox - nId - the Id of the selected button, or 0 (zero) if Cancelled or -1 for timed out 37 | * For InputBoxes, according to each type, as follows: 38 | * - "@I", "@I!", "@IP" - returns the character entered, or an empty string if "Cancel" 39 | * - "@IN", "@ID" - returns a numeric value, or an empty string if cancelled. - Notice that cancel returns a Character empty string! 40 | * - "@D", "@M" - returns a Date format value 41 | * - "@T" - returns a DateTime format value 42 | * - "@R" - returns an object with two properties: "StartDate" and "EndDate" 43 | 44 | 45 | #DEFINE BM_SETIMAGE 0xF7 46 | 47 | * Task Dialog Messages 48 | * https://docs.microsoft.com/en-us/windows/win32/controls/bumper-task-dialogs-reference-messages 49 | #DEFINE TDM_SET_MARQUEE_PROGRESS_BAR 0x00000467 50 | #DEFINE TDM_SET_PROGRESS_BAR_STATE 0x00000468 51 | #DEFINE TDM_SET_PROGRESS_BAR_RANGE 0x00000469 52 | #DEFINE TDM_SET_PROGRESS_BAR_POS 0x0000046A 53 | #DEFINE TDM_SET_PROGRESS_BAR_MARQUEE 0x0000046B 54 | #DEFINE TDM_SET_ELEMENT_TEXT 0x0000046C 55 | #DEFINE TDM_UPDATE_ICON 0x00000474 56 | 57 | * Task Dialog Notifications - Used in Callbacks, for TaskDialogIndirect API 58 | * https://docs.microsoft.com/en-us/windows/win32/controls/bumper-task-dialogs-reference-notifications 59 | 60 | 61 | #DEFINE PBST_NORMAL 0x0001 62 | #DEFINE PBST_ERROR 0x0002 63 | #DEFINE PBST_PAUSED 0x0003 64 | 65 | #DEFINE TDE_CONTENT 0 66 | #DEFINE TDE_EXPANDED_INFORMATION 1 67 | #DEFINE TDE_FOOTER 2 68 | #DEFINE TDE_MAIN_INSTRUCTION 3 69 | 70 | * Enum TASKDIALOG_ICON_ELEMENTS 71 | #DEFINE TDIE_ICON_MAIN 0 72 | #DEFINE TDIE_ICON_FOOTER 1 73 | 74 | #DEFINE ICON_EMPTY 14 75 | 76 | * Task DIalog Common Buttons 77 | #DEFINE TDCBF_OK_BUTTON 1 78 | #DEFINE TDCBF_YES_BUTTON 2 79 | #DEFINE TDCBF_NO_BUTTON 4 80 | #DEFINE TDCBF_CANCEL_BUTTON 8 81 | #DEFINE TDCBF_RETRY_BUTTON 0x0010 82 | #DEFINE TDCBF_CLOSE_BUTTON 0x0020 83 | 84 | #DEFINE S_OK 0 85 | 86 | * Task dialog Icons 87 | #DEFINE TD_WARNING_ICON -1 && ! 88 | #DEFINE TD_ERROR_ICON -2 && X 89 | #DEFINE TD_INFORMATION_ICON -3 && i 90 | #DEFINE TD_SHIELD_ICON -4 && Shield 91 | #DEFINE TD_SHIELD_GRADIENT_ICON -5 && Shield Green BackGnd 92 | #DEFINE TD_SHIELD_WARNING_ICON -6 && ! Yellow BackGnd 93 | #DEFINE TD_SHIELD_ERROR_ICON -7 && X Red BackGnd 94 | #DEFINE TD_SHIELD_OK_ICON -8 && Ok Green BackGnd 95 | #DEFINE TD_SHIELD_GRAY_ICON -9 && Shield Silver BackGnd 96 | #DEFINE IDI_APPLICATION 0x00007f00 && App 97 | #DEFINE IDI_QUESTION 0x00007f02 && ? 98 | 99 | #DEFINE GW_HWNDFIRST 0 100 | #DEFINE GW_HWNDLAST 1 101 | #DEFINE GW_HWNDNEXT 2 102 | #DEFINE GW_CHILD 5 103 | 104 | * Windows Messages Codes 105 | * https://www.autoitscript.com/autoit3/docs/appendix/WinMsgCodes.htm 106 | #DEFINE WM_ACTIVATE 0x0006 107 | #DEFINE WM_SETFOCUS 0x0007 108 | #DEFINE WM_KILLFOCUS 0x0008 109 | #DEFINE WM_SETFONT 48 110 | #DEFINE WM_SETTEXT 0x000C 111 | #DEFINE WM_GETTEXT 0x000D 112 | #DEFINE WM_GETTEXTLENGTH 0x000E 113 | #DEFINE WM_GETDLGCODE 0x0087 114 | #DEFINE WM_KEYDOWN 0x0100 115 | #DEFINE WM_KEYUP 0x0101 116 | #DEFINE WM_COMMAND 0x0111 117 | #DEFINE WM_SYSCOMMAND 0x0112 118 | #DEFINE WM_LBUTTONDOWN 0x0201 119 | #DEFINE WM_LBUTTONUP 0x0202 120 | #DEFINE WM_RBUTTONDOWN 0x0204 121 | #DEFINE WM_PARENTNOTIFY 0x0210 122 | 123 | 124 | #DEFINE SC_CLOSE 0xF060 125 | 126 | #DEFINE XMB_TIMERINTERVAL 200 && Miliseconds 127 | 128 | * Window Styles 129 | * https://docs.microsoft.com/en-us/windows/win32/winmsg/window-styles 130 | #DEFINE WS_OVERLAPPED 0x0 131 | #DEFINE WS_TABSTOP 0x00010000 132 | #DEFINE WS_MAXIMIZEBOX 0x00010000 133 | #DEFINE WS_MINIMIZEBOX 0x00020000 134 | #DEFINE WS_GROUP 0x00020000 135 | #DEFINE WS_THICKFRAME 0x00040000 136 | #DEFINE WS_SYSMENU 0x00080000 137 | #DEFINE WS_HSCROLL 0x00100000 138 | #DEFINE WS_VSCROLL 0x00200000 139 | #DEFINE WS_DLGFRAME 0x00400000 140 | #DEFINE WS_BORDER 0x00800000 141 | #DEFINE WS_CAPTION (WS_BORDER + WS_DLGFRAME) 142 | #DEFINE WS_MAXIMIZE 0x01000000 143 | #DEFINE WS_CLIPCHILDREN 0x02000000 144 | #DEFINE WS_CLIPSIBLINGS 0x04000000 145 | #DEFINE WS_DISABLED 0x08000000 146 | #DEFINE WS_VISIBLE 0x10000000 147 | #DEFINE WS_MINIMIZE 0x20000000 148 | #DEFINE WS_CHILD 0x40000000 149 | #DEFINE WS_POPUP 0x80000000 150 | 151 | * Extended Window styles 152 | * https://docs.microsoft.com/en-us/windows/win32/winmsg/extended-window-styles 153 | #DEFINE WS_EX_CLIENTEDGE 0x200 && The window has a border with a sunken edge. 154 | #DEFINE WS_EX_COMPOSITED 0x02000000 155 | #DEFINE WS_EX_STATICEDGE 0x00020000 && The window has a three-dimensional border style intended to be used for items that do not accept user input. 156 | #DEFINE WS_EX_WINDOWEDGE 0x00000100 && The window has a border with a raised edge. 157 | #DEFINE WS_EX_CONTROLPARENT 0x00010000 158 | #DEFINE WS_EX_LEFT 0 159 | #DEFINE WS_EX_LTRREADING 0 160 | #DEFINE WS_EX_RIGHTSCROLLBAR 0 161 | #DEFINE WS_EX_TRANSPARENT 0x00020 162 | #DEFINE WS_EX_LAYERED 0x80000 163 | 164 | * Edit control styles 165 | * https://docs.microsoft.com/en-us/windows/win32/controls/edit-control-styles 166 | #DEFINE ES_LEFT 0x0000 167 | #DEFINE ES_CENTER 0x0001 168 | #DEFINE ES_RIGHT 0x0002 169 | #DEFINE ES_AUTOHSCROLL 0x0080 170 | #DEFINE ES_PASSWORD 0x0020 && Displays an asterisk (*) for each character typed into the edit control. 171 | && This style is valid only for single-line edit controls. 172 | && To change the characters that is displayed, or set or clear this style, use the EM_SETPASSWORDCHAR message. 173 | #DEFINE ES_MULTILINE 0x0004 174 | #DEFINE ES_UPPERCASE 0x0008 175 | #DEFINE ES_LOWERCASE 0x0010 176 | #DEFINE ES_AUTOVSCROLL 0x0040 177 | #DEFINE ES_AUTOHSCROLL 0x0080 178 | #DEFINE ES_NOHIDESEL 0x0100 179 | #DEFINE ES_OEMCONVERT 0x0400 180 | #DEFINE ES_READONLY 0x0800 181 | #DEFINE ES_WANTRETURN 0x1000 182 | #DEFINE ES_NUMBER 0x2000 183 | 184 | * SystemTime enum 185 | #DEFINE DTM_FIRST 0x1000 186 | #DEFINE DTM_GETSYSTEMTIME 0x1001 187 | #DEFINE DTM_SETSYSTEMTIME 0x1002 188 | #DEFINE DTM_SETRANGE 0x1004 189 | 190 | #DEFINE EM_GETSEL 0x00B0 191 | #DEFINE EM_SETSEL 0x00B1 192 | #DEFINE EM_SELECTALL 0x00B2 193 | 194 | #DEFINE IMAGE_BITMAP 0 195 | #DEFINE IMAGE_ICON 1 196 | #DEFINE LR_LOADFROMFILE 0x0010 197 | #DEFINE LR_DEFAULTSIZE 0x0040 198 | 199 | 200 | * Month Calendar Messages 201 | #define MCM_GETCURSEL 0x1001 202 | #define MCM_SETCURSEL 0x1002 203 | #define MCM_GETMAXSELCOUNT 0x1003 204 | #define MCM_SETMAXSELCOUNT 0x1004 205 | #define MCM_GETSELRANGE 0x1005 206 | #define MCM_SETSELRANGE 0x1006 207 | #define MCM_GETMONTHRANGE 0x1007 208 | #define MCM_SETDAYSTATE 0x1008 209 | #define MCM_GETMINREQRECT 0x1009 210 | #define MCM_SETCOLOR 0x100a 211 | #define MCM_GETCOLOR 0x100b 212 | #define MCM_SETTODAY 0x100c 213 | #define MCM_GETTODAY 0x100d 214 | #define MCM_HITTEST 0x100e 215 | #define MCM_SETFIRSTDAYOFWEEK 0x100f 216 | #define MCM_GETFIRSTDAYOFWEEK 0x1010 217 | #define MCM_GETRANGE 0x1011 218 | #define MCM_SETRANGE 0x1012 219 | #define MCM_GETMONTHDELTA 0x1013 220 | #define MCM_SETMONTHDELTA 0x1014 221 | #define MCN_SELCHANGE (-749) 222 | #define MCN_GETDAYSTATE (-747) 223 | #define MCN_SELECT (-746) 224 | 225 | 226 | 227 | * https://www.rpi.edu/dept/cis/software/g77-mingw32/include/commctrl.h 228 | 229 | 230 | 231 | FUNCTION FoxyDialog(tcTitle, tcInstruction, tcContent, tnIcon, tcButtons, tnDefaultBtn, tnTimeout) && , tcTimeoutCaption2) 232 | 233 | LOCAL ldDefaultDate, lnPos 234 | SET LIBRARY TO vfp2c32.fll ADDITIVE 235 | LOCAL loMsgB, lnOption 236 | m.loMsgB = CREATEOBJECT("xmbMsgBoxEx") 237 | 238 | LOCAL lcDialogType 239 | lcDialogType = ALLTRIM(UPPER(GETWORDNUM(m.tcButtons,1,","))) 240 | DO CASE 241 | CASE LEFT(lcDialogType, 2) = "@I" && Inputbox 242 | m.loMsgB.nDialogType = 2 && InputBox 243 | lnPos = AT(",",tcButtons,1) 244 | tcButtons = SUBSTR(tcButtons,lnPos) 245 | tcContent = tcContent + CHR(13) + CHR(13) + CHR(13) 246 | 247 | DO CASE 248 | CASE VARTYPE(m.tnDefaultBtn) = "N" AND INLIST(lcDialogType, "@ID", "@II", "@IN") && Digits or Integer 249 | m.loMsgB._cDefaultInput = TRANSFORM(m.tnDefaultBtn) 250 | OTHERWISE 251 | m.loMsgB._cDefaultInput = EVL(m.tnDefaultBtn,"") 252 | ENDCASE 253 | 254 | tnDefaultBtn = 1 255 | * Store the formatting information 256 | m.loMsgB._cEditBoxFmt = UPPER(SUBSTR(m.lcDialogType, 3)) 257 | m.loMsgB._cEditBoxNumeric = "-0123456789" + SET("Point") 258 | m.loMsgB._SetPoint = SET("Point") 259 | CASE INLIST(lcDialogType, "@D", "@T", "@M", "@R") && DateBox, DateTimeBox, MonthBox, DateRangeBox 260 | tcButtons = SUBSTR(tcButtons,3) 261 | 262 | DO CASE 263 | CASE lcDialogType = "@D" 264 | tcContent = tcContent + CHR(13) + CHR(13) + CHR(13) 265 | m.loMsgB.nDialogType = 3 266 | 267 | CASE lcDialogType = "@T" 268 | tcContent = tcContent + CHR(13) + CHR(13) + CHR(13) 269 | m.loMsgB.nDialogType = 4 270 | 271 | CASE lcDialogType = "@M" 272 | tcContent = tcContent + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) 273 | m.loMsgB.nDialogType = 5 274 | 275 | CASE lcDialogType = "@R" 276 | tcContent = tcContent + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) + CHR(13) 277 | m.loMsgB.nDialogType = 6 278 | 279 | OTHERWISE 280 | ENDCASE 281 | 282 | DO CASE 283 | CASE VARTYPE(tnDefaultBtn) = "C" 284 | ldDefaultDate = EVL(CTOD(m.tnDefaultBtn), {}) 285 | CASE VARTYPE(tnDefaultBtn) = "D" 286 | ldDefaultDate = m.tnDefaultBtn 287 | CASE VARTYPE(m.tnDefaultBtn) = "T" AND lcDialogType = "@T" 288 | m.loMsgB._dDefaultDateTime = m.tnDefaultBtn 289 | ldDefaultDate = TTOD(m.tnDefaultBtn) 290 | CASE VARTYPE(tnDefaultBtn) = "T" 291 | ldDefaultDate = TTOD(m.tnDefaultBtn) 292 | OTHERWISE 293 | ldDefaultDate = {} 294 | ENDCASE 295 | m.loMsgB._dDefaultDate = m.ldDefaultDate 296 | tnDefaultBtn = 1 297 | 298 | OTHERWISE && Normal Dialog 299 | 300 | ENDCASE 301 | 302 | m.lnOption = m.loMsgB.SendMessage(m.tcTitle, m.tcInstruction, m.tcContent, m.tnIcon, m.tcButtons, m.tnDefaultBtn, m.tnTimeout) &&, m.tcTimeoutCaption2) 303 | m.loMsgB = NULL 304 | 305 | RETURN m.lnOption 306 | ENDFUNC 307 | 308 | 309 | DEFINE CLASS xmbMsgBoxEx AS CUSTOM 310 | Interval = 0 311 | nXmbTimeout = 0 312 | hDialog = 0 313 | nSeconds = SECONDS() 314 | cHeading = "" 315 | _hDialogUI = 0 316 | cFontName = "Arial" 317 | nFontSize = 9 318 | nDefaultBtn = 1 319 | nRows = 1 320 | nButtons = 0 321 | cTimeoutCaption = "" 322 | nIconBack = 0 323 | nIconMain = 0 324 | lFakeTimeOut = .F. 325 | nDefaultInterval = XMB_TIMERINTERVAL 326 | hLibImageRes = 0 327 | hLibShell32 = 0 328 | nDialogType = 1 && 1=Normal dialog, 2=INPUTBOX dialog, 3=DateBox, 4=MonthCalendar, 5=DateRangeCalendar 329 | _lUpdatedIcon = .F. 330 | _hEditBox = 0 331 | _cEditBoxFmt = "" && !U=ES_UPPERCASE, DI=ES_NUMERIC, P=ES_PASSWORD, L=ES_LOWERCASE, N=All accepted, internally formatted 332 | _cEditBoxNumeric = "0123456789" 333 | _SetPoint = "." 334 | _cInputText = "" 335 | _dInputDate = {} 336 | _dInputDate2 = {} 337 | _tInputDateTime = "" 338 | _hDateBox = 0 339 | _hTimeBox = 0 340 | _dDefaultDate = {} 341 | _dDefaultDateTime = {//::} 342 | _nOriginalTimeout = 0 && value<=0 = no timer 343 | _cDefaultInput = "" 344 | _nLastButton = 0 345 | _hCustomControl = 0 346 | _hExternalIcon = 0 347 | _cExternalIconFile = "" 348 | _hStaticImage = 0 349 | _hStaticLabel = 0 350 | PROCEDURE DeclareAPI 351 | 352 | * We need to put the API declaration here to avoid acrazy error ??? 353 | DECLARE SHORT TaskDialog IN comctl32 ; 354 | AS xmbTaskDialog ; 355 | INTEGER hWndParent, INTEGER hInstance, ; 356 | STRING pszWindowTitle, STRING pszMainInstruction, ; 357 | STRING pszContent, INTEGER dwCommonButtons, ; 358 | INTEGER pszIcon, INTEGER @pnButton 359 | 360 | DECLARE LONG LoadLibrary IN kernel32 AS LoadLibraryA STRING lpLibFileName 361 | 362 | DECLARE LONG FreeLibrary IN kernel32 LONG hLibModule 363 | 364 | DECLARE LONG LoadImage IN user32 AS LoadImageA ; 365 | LONG hinst, LONG lpsz, LONG dwImageType, LONG dwDesiredWidth, LONG dwDesiredHeight, LONG dwFlags 366 | 367 | DECLARE LONG DestroyIcon IN user32 LONG hIcon 368 | 369 | DECLARE INTEGER CreateWindowEx IN user32 AS CreateWindowEx; 370 | INTEGER dwExStyle, STRING lpClassName,; 371 | STRING lpWindowName, INTEGER dwStyle,; 372 | INTEGER x, INTEGER y, INTEGER nWidth, INTEGER nHeight,; 373 | INTEGER hWndParent, INTEGER hMenu, INTEGER hInstance,; 374 | INTEGER lpParam 375 | 376 | DECLARE INTEGER GetWindowRect IN user32 INTEGER hwnd, STRING @lpRect 377 | DECLARE INTEGER GetClientRect IN user32 INTEGER hWindow, STRING @lpRect 378 | DECLARE INTEGER GetWindowLong IN user32 INTEGER hWnd, INTEGER nIndex 379 | 380 | DECLARE LONG GetStockObject IN gdi32.dll LONG nIndex 381 | DECLARE INTEGER SendMessageW IN user32 INTEGER hwindow, INTEGER msg, INTEGER wParam, INTEGER LPARAM 382 | DECLARE INTEGER SendMessageW IN user32 as SendMessageWText INTEGER hwindow, INTEGER msg, INTEGER wParam, STRING LPARAM 383 | DECLARE integer SetFocus IN WIN32API integer 384 | ENDPROC 385 | 386 | 387 | PROCEDURE Init 388 | This.AddProperty("aKeys[1,4]", .F.) 389 | This.aKeys(1, 3) = 0 390 | This.AddObject("oTimer", "xmbTimer") 391 | This.AddProperty("aButtonsHwnd[1]", 0) 392 | This.DeclareAPI 393 | ENDPROC 394 | 395 | 396 | PROCEDURE SendMessage(tcTitle, tcInstruction, tcContent, tnIcon, tcButtons, tnDefaultBtn, tnTimeout) && , tcTimeoutCaption) 397 | LOCAL loRange as "EMPTY" 398 | LOCAL lnIcontoSend 399 | m.tcTitle = EVL(m.tcTitle, "") 400 | m.tcInstruction = EVL(m.tcInstruction, "") 401 | m.tcContent = EVL(m.tcContent, "") 402 | m.tcButtons = EVL(m.tcButtons, "Ok") 403 | 404 | LOCAL lnButtons, lnResult, N, lnButtonId, lcCaption2 405 | LOCAL laAnswer[1], laButtonId[1], lnOffset, lnPos, lnReturn, lnlast 406 | LOCAL lnBtnCount 407 | m.lnBtnCount = GETWORDCOUNT(m.tcButtons, ",") 408 | IF m.lnBtnCount > 6 409 | MESSAGEBOX("Maximum buttons available is 6!",16,"Dialog error") 410 | RETURN .F. 411 | ENDIF 412 | 413 | m.lcCaption2 = "" 414 | IF VARTYPE(m.tnTimeout) = "C" 415 | m.lcCaption2 = GETWORDNUM(m.tnTimeout,2,",") 416 | m.tnTimeout = VAL(GETWORDNUM(m.tnTimeout,1,",")) 417 | ENDIF 418 | 419 | IF NOT VARTYPE(m.tnDefaultBtn) $ "NL" 420 | MESSAGEBOX("Invalid parameter for the default button!",16,"Dialog error") 421 | RETURN .F. 422 | ENDIF 423 | This.nDefaultBtn = IIF(EMPTY(m.tnDefaultBtn), 1, m.tnDefaultBtn) 424 | IF NOT BETWEEN(This.nDefaultBtn,1,m.lnBtnCount) 425 | This.nDefaultBtn = 1 426 | ENDIF 427 | 428 | 429 | This.PrepareMainIcon(m.tnIcon) 430 | m.lnIcontoSend = IIF(INLIST(This.nIconBack,0,ICON_EMPTY), This.nIconMain, This.nIconBack) 431 | 432 | 433 | * If there is no timeout, we'll still use a fake timer to make some initial adjustments after the dialog is created 434 | This._nOriginalTimeout = EVL(m.tnTimeout,0) 435 | IF EMPTY(m.tnTimeout) 436 | m.tnTimeout = 1000 437 | This.lFakeTimeout = .T. 438 | ENDIF 439 | This.nXmbTimeout = IIF(VARTYPE(m.tnTimeout)="N", m.tnTimeout, 0) 440 | 441 | This.cTimeoutCaption = EVL(m.lcCaption2, "") 442 | IF NOT EMPTY(m.lcCaption2) 443 | LOCAL lcFontName, lnFontSize 444 | =GetDialogFont(@m.lcFontName, @m.lnFontSize) 445 | This.cFontName = EVL(m.lcFontName, "Arial") 446 | This.nFontSize = EVL(m.lnFontSize, 9) 447 | 448 | IF NOT "" $ m.lcCaption2 449 | This.cTimeoutCaption = " - " + "" + m.lcCaption2 450 | ENDIF 451 | ENDIF 452 | 453 | LOCAL lnButtonsA 454 | This.nButtons = m.lnBtnCount 455 | DIMENSION THIS.aButtonsHwnd(m.lnBtnCount) 456 | 457 | THIS.ADDPROPERTY("aButtons[1,2]", "") 458 | DIMENSION THIS.aButtons(m.lnBtnCount, 2) 459 | DIMENSION m.laButtonId(6) 460 | m.laButtonId(1) = 32 461 | m.laButtonId(2) = 32 + 16 462 | m.laButtonId(3) = 32 + 16 + 8 463 | m.laButtonId(4) = 32 + 16 + 8 + 4 464 | m.laButtonId(5) = 32 + 16 + 8 + 4 + 2 465 | m.laButtonId(6) = 32 + 16 + 8 + 4 + 2 + 1 466 | 467 | LOCAL lcBtnComplete, lcBtnCaption, lnBtnIcon 468 | FOR m.N = 1 TO m.lnBtnCount 469 | lcBtnComplete = GETWORDNUM(m.tcButtons, m.N, ",") 470 | lcBtnCaption = GETWORDNUM(m.lcBtnComplete, 1, "_") 471 | lnBtnIcon = VAL(GETWORDNUM(m.lcBtnComplete, 2, "_")) 472 | 473 | * Update predefined Unicode buttons 474 | IF "*" $ m.lcBtnCaption 475 | DO CASE 476 | CASE LOWER(m.lcBtnCaption) = "ok*" 477 | m.lcBtnCaption = "Ok 2713" 478 | CASE LOWER(m.lcBtnCaption) = "cancel*" 479 | m.lcBtnCaption = "Cancel d83dddd9" 480 | CASE LOWER(m.lcBtnCaption) = "print*" 481 | m.lcBtnCaption = "Print 2399" 482 | CASE LOWER(m.lcBtnCaption) = "save*" 483 | m.lcBtnCaption = "Save d83dddab" 484 | CASE LOWER(m.lcBtnCaption) = "search*" 485 | m.lcBtnCaption = "Search d83ddd0e" 486 | OTHERWISE 487 | ENDCASE 488 | ENDIF 489 | 490 | * Update predefined colored icons 491 | IF "#" $ m.lcBtnCaption 492 | DO CASE 493 | CASE LOWER(m.lcBtnCaption) = "ok#" 494 | m.lcBtnCaption = "Ok_116802" 495 | CASE LOWER(m.lcBtnCaption) = "cancel#" 496 | m.lcBtnCaption = "Cancel_89" 497 | CASE LOWER(m.lcBtnCaption) = "print#" 498 | m.lcBtnCaption = "Print_51" 499 | CASE LOWER(m.lcBtnCaption) = "save#" 500 | m.lcBtnCaption = "Save_116761" 501 | CASE LOWER(m.lcBtnCaption) = "search#" 502 | m.lcBtnCaption = "Search_116774" 503 | OTHERWISE 504 | ENDCASE 505 | lnBtnIcon = VAL(GETWORDNUM(m.lcBtnCaption, 2, "_")) 506 | lcBtnCaption = GETWORDNUM(m.lcBtnCaption, 1, "_") 507 | ENDIF 508 | 509 | THIS.aButtons(m.N, 1) = lcBtnCaption 510 | THIS.aButtons(m.N, 2) = m.lnBtnIcon 511 | m.lnButtonsA = m.laButtonId(m.N) 512 | ENDFOR 513 | 514 | m.tcTitle = ToUnicode(m.tcTitle) 515 | m.tcInstruction = ToUnicode(m.tcInstruction) 516 | m.tcContent = ToUnicode(m.tcContent) 517 | 518 | * a substitute for the MAKEINTRESOURCE 519 | m.lnIcontoSend = BITAND(0x0000ffff, m.lnIcontoSend) 520 | m.lnButtons = m.lnButtonsA 521 | m.lnButtonId = 0 && the must 522 | 523 | BINDEVENT(0, WM_KEYUP, This, 'WndProc') 524 | BINDEVENT(0, WM_ACTIVATE, This, 'WndProc') 525 | 526 | m.lnResult = xmbTaskDialog(_SCREEN.HWND, 0, m.tcTitle, ; 527 | m.tcInstruction, m.tcContent, m.lnButtons, m.lnIcontoSend, @m.lnButtonId) 528 | 529 | UNBINDEVENTS(0, WM_ACTIVATE) 530 | 531 | DO CASE 532 | CASE m.lnResult < 0 533 | m.lnReturn = 0 534 | CASE m.lnBtnCount = 2 AND m.lnButtonId = 4 && 1st button 535 | m.lnReturn = 1 536 | OTHERWISE 537 | DIMENSION m.laAnswer(6) 538 | m.laAnswer(1) = 1 539 | m.laAnswer(2) = 6 540 | m.laAnswer(3) = 7 541 | m.laAnswer(4) = 4 542 | m.laAnswer(5) = 2 543 | m.laAnswer(6) = 8 544 | m.lnPos = ASCAN(m.laAnswer, m.lnButtonId) 545 | m.lnOffset = 6 - m.lnBtnCount + 1 546 | m.lnReturn = m.lnPos - m.lnOffset + 1 547 | ENDCASE 548 | 549 | * Last check to know if CANCEL or was pressed 550 | INKEY(.2) 551 | m.lnlast = This.aKeys(ALEN(This.aKeys, 1), 3) 552 | DO CASE 553 | CASE This.nXmbTimeout = -1 554 | m.lnReturn = -1 555 | CASE m.lnlast = 27 556 | m.lnReturn = 0 557 | OTHERWISE 558 | ENDCASE 559 | UNBINDEVENTS( 0, WM_KEYUP ) && Free the Keyboard 560 | 561 | DO CASE 562 | CASE This.nDialogType = 2 && INPUTBOX 563 | 564 | LOCAL llNumeric, lnOrigDecimals, lnDecimals, lnPos 565 | IF "N" $ This._cEditBoxFmt OR ; 566 | "D" $ This._cEditBoxFmt OR ; 567 | "I" $ This._cEditBoxFmt && Numeric Inputbox 568 | llNumeric = .T. 569 | ENDIF 570 | 571 | IF This._nLastButton = 2 && Cancel 572 | RETURN "" 573 | ELSE 574 | IF llNumeric && trick to use VAL() and bypass the SET("Decimals") 575 | lnOrigDecimals = SET("Decimals") 576 | lnPos = AT(SET("Point"),This._cInputText) 577 | lnDecimals = IIF(lnPos=0,0,LEN(SUBSTR(This._cInputText, lnPos + 1))) 578 | SET DECIMALS TO (lnDecimals) 579 | lnReturn = VAL(This._cInputText) 580 | SET DECIMALS TO (lnOrigDecimals) 581 | RETURN lnReturn 582 | ELSE 583 | RETURN This._cInputText 584 | ENDIF 585 | ENDIF 586 | 587 | CASE This.nDialogType = 3 && DATEBOX 588 | IF This._nLastButton = 2 && Cancel 589 | RETURN "" 590 | ELSE 591 | RETURN This._dInputDate 592 | ENDIF 593 | 594 | CASE This.nDialogType = 4 && DATETIME BOX 595 | IF This._nLastButton = 2 && Cancel 596 | RETURN "" 597 | ELSE 598 | RETURN This._tInputDateTime 599 | ENDIF 600 | 601 | CASE This.nDialogType = 5 && MONTHCALENDAR BOX 602 | IF This._nLastButton = 2 && Cancel 603 | RETURN "" 604 | ELSE 605 | RETURN This._dInputDate 606 | ENDIF 607 | 608 | CASE This.nDialogType = 6 && MONTHCALENDAR RANGE BOX 609 | loRange = CREATEOBJECT("EMPTY") 610 | IF This._nLastButton = 2 && Cancel 611 | ADDPROPERTY(loRange, "StartDate", {}) 612 | ADDPROPERTY(loRange, "EndDate" , {}) 613 | ELSE 614 | ADDPROPERTY(loRange, "StartDate", This._dInputDate) 615 | ADDPROPERTY(loRange, "EndDate" , This._dInputDate2) 616 | ENDIF 617 | RETURN loRange 618 | 619 | OTHERWISE 620 | RETURN m.lnReturn && Default dialog 621 | 622 | ENDCASE 623 | 624 | ENDPROC 625 | 626 | 627 | * Windows event handler procedure 628 | * MSDN WindowProc callback function 629 | * http://msdn.microsoft.com/en-us/library/windows/desktop/ms633573(v=vs.85).aspx 630 | * http://hermantan.blogspot.com/2008/07/centering-vfp-messagebox-in-any-form.html 631 | * Here we will make all the modifications in the Windows dialog 632 | PROCEDURE WndProc( th_Wnd, tn_Msg, t_wParam, t_lParam) 633 | 634 | LOCAL lcCaption, lcText, lhFirst, lhLast, lhLastFound, lhWindow, lhWndButton, lnButton, lhWndMain 635 | LOCAL lnRows, n, liIcon 636 | IF (m.tn_Msg == WM_ACTIVATE) AND (m.t_wParam == 0) AND (m.t_lParam <> 0) 637 | 638 | m.lhWndMain = m.t_lParam 639 | This.hDialog = m.lhWndMain 640 | 641 | * Getting the 1st Client Window 642 | m.lhWindow = 0 643 | m.lhLastFound = 0 644 | DO WHILE .T. 645 | m.lhWindow = xmbFindWindowEx(m.lhWndMain, m.lhWindow, NULL, NULL) 646 | 647 | IF m.lhWindow = 0 648 | * 123=ERROR_INVALID_NAME 649 | * 127=ERROR_PROC_NOT_FOUND 650 | * DECLARE INTEGER GetLastError IN kernel32 651 | * ? "Exit on error:", GetLastError() 652 | EXIT 653 | ELSE 654 | m.lhLastFound = m.lhWindow 655 | ENDIF 656 | ENDDO 657 | 658 | This._hDialogUI = m.lhLastFound && This is the dialog UI, that contains the buttons, and will receive the EditBox if nDialogType = 2 659 | 660 | * Set the focus at the desired button 661 | FOR m.n = 1 TO This.nDefaultBtn - 1 662 | KEYBOARD '{TAB}' 663 | ENDFOR 664 | 665 | * Getting the Child objects from the client Window 666 | m.lhWindow = m.lhLastFound 667 | m.lhFirst = xmbGetWindow(m.lhWindow, GW_CHILD) 668 | m.lhWindow = xmbGetWindow(m.lhFirst, GW_HWNDFIRST) 669 | m.lhLast = xmbGetWindow(m.lhFirst, GW_HWNDLAST) 670 | 671 | m.lnButton = 0 672 | DO WHILE .T. 673 | m.lhWndButton = xmbFindWindowEx(m.lhWindow, 0, NULL, NULL) 674 | m.lcText = ALLTRIM(GetWinText(m.lhWndButton)) 675 | 676 | * Changing the captions 677 | IF NOT EMPTY(m.lcText) && AND GetWindowClass(lhWndButton) = "Button" 678 | m.lnButton = m.lnButton + 1 679 | 680 | * Store the button hWnd 681 | This.aButtonsHwnd(m.lnButton) = m.lhWndButton 682 | m.lcCaption = THIS.aButtons(m.lnButton, 1) 683 | * Disable button if needed 684 | IF LEFT(m.lcCaption, 1) = "\" 685 | m.lcCaption = SUBSTR(m.lcCaption, 2) && get the rest of the string 686 | =xmbEnableWindow(m.lhWndButton, 0) 687 | ENDIF 688 | 689 | m.lcCaption = TOUNICODE(m.lcCaption) 690 | =xmbSetWindowTextZ(m.lhWndButton, m.lcCaption) 691 | 692 | * Adding the button icons 693 | m.liIcon = This.aButtons(m.lnButton, 2) 694 | IF NOT EMPTY(m.liIcon) 695 | =This.SetButtonIcon(m.lhWndButton, 1, m.liIcon) 696 | ENDIF 697 | ELSE 698 | *!* * Close a window having its handle 699 | *!* #DEFINE WM_SYSCOMMAND 0x0112 700 | *!* #DEFINE SC_CLOSE 0xF060 701 | *!* XmbSendMessage(lhWndButton, WM_SYSCOMMAND, SC_CLOSE, 0) 702 | ENDIF 703 | 704 | * Disable the 'X' close button 705 | IF m.lhWindow = m.lhLast 706 | * Declare Integer GetSystemMenu In User32 Integer HWnd, Integer bRevert 707 | * Declare INTEGER EnableMenuItem IN User32 Long hMenu, LONG wIDEnableItem, LONG wEnable 708 | * DECLARE LONG GetMenuItemCount IN user32 LONG hMenu 709 | * DECLARE LONG RemoveMenu IN user32 LONG HMENU, LONG NPOSITION, LONG WFLAGS 710 | #DEFINE SC_CLOSE 0xF060 711 | #DEFINE MF_BYCOMMAND 0 712 | #DEFINE MF_BYPOSITION 0x400 713 | #DEFINE MF_CHECKED 8 714 | #DEFINE MF_DISABLED 2 715 | #DEFINE MF_GRAYED 1 716 | #DEFINE MF_REMOVE 0x00001000 717 | 718 | * EnableMenuItem(GetSystemMenu(t_lParam, 0), SC_CLOSE, MF_BYCOMMAND + MF_DISABLED + MF_GRAYED) 719 | xmbEnableMenuItem(xmbGetSystemMenu(m.t_lParam, 0), SC_CLOSE, MF_DISABLED) 720 | EXIT 721 | ENDIF 722 | m.lhWindow = xmbGetWindow(m.lhWindow, GW_HWNDNEXT) 723 | ENDDO 724 | 725 | * All buttons initialized, start timer, if needed 726 | IF This.nXmbTimeout > 1 727 | This.nXmbTimeout = This.nXmbTimeout && - (SECONDS() - This.nSeconds)*1000 && Discount the elapsed time 728 | This.oTimer.Interval = 35 729 | This.oTimer.Enabled = .T. 730 | This.oTimer.nCurrentTimeout = ROUND(This.nXmbTimeout / 1000,0) 731 | 732 | IF NOT EMPTY(This.cTimeoutCaption) 733 | This.cHeading = ALLTRIM(GetWinText(This.hDialog)) 734 | 735 | * Obtain the Dialog width 736 | LOCAL lcNewHeading, lnLeft, lnRemain, lnRepeat, lnRight, lnSizeCompl, lnSizeSpace, lnSizeTitle 737 | LOCAL lnWidth, lcRect 738 | m.lcRect = REPLICATE(CHR(0),16) 739 | = GetWindowRect(This.hDialog, @m.lcRect) 740 | m.lnLeft = CTOBIN(SUBSTR(m.lcRect, 1,4),"4RS") 741 | m.lnRight = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS") 742 | m.lnWidth = m.lnRight - m.lnLeft 743 | *lnTop = CTOBIN(SUBSTR(lcRect, 5,4),"4RS") 744 | *lnBottom = CTOBIN(SUBSTR(lcRect, 13,4),"4RS") 745 | 746 | m.lnSizeTitle = getTextSize(This.cHeading, This.cFontName, This.nFontSize) 747 | m.lnSizeCompl = getTextSize(ALLTRIM(This.cTimeoutCaption), This.cFontName, This.nFontSize) 748 | m.lnSizeSpace = getTextSize(SPACE(10), This.cFontName, This.nFontSize) 749 | 750 | m.lnRemain = m.lnWidth - m.lnSizeTitle - m.lnSizeCompl 751 | m.lnRepeat = FLOOR(m.lnRemain / m.lnSizeSpace) - 1 752 | 753 | IF m.lnRepeat > 0 754 | m.lcNewHeading = This.cHeading + REPLICATE(SPACE(10),m.lnRepeat) + ALLTRIM(This.cTimeoutCaption) 755 | ELSE 756 | m.lcNewHeading = This.cHeading + This.cTimeoutCaption 757 | ENDIF 758 | 759 | This.cHeading = m.lcNewHeading 760 | ENDIF 761 | 762 | ENDIF 763 | 764 | ENDIF 765 | 766 | IF m.tn_Msg == WM_KEYUP 767 | m.lnRows = This.nRows + 1 768 | DIMENSION This.aKeys(m.lnRows, 4) 769 | This.aKeys(m.lnRows, 1) = m.th_Wnd 770 | This.aKeys(m.lnRows, 2) = m.tn_Msg 771 | This.aKeys(m.lnRows, 3) = m.t_wParam 772 | This.aKeys(m.lnRows, 4) = m.t_lParam 773 | ENDIF 774 | 775 | LOCAL pOrgProc 776 | m.pOrgProc = xmbGetWindowLong( _VFP.HWND, -4 ) 777 | = xmbCallWindowProc( m.pOrgProc, m.th_Wnd, m.tn_Msg, m.t_wParam, m.t_lParam ) 778 | ENDPROC 779 | 780 | 781 | PROCEDURE PrepareMainIcon(tnIcon) 782 | LOCAL lnIconMain, lnIconBack, lcIconMain, lcIconBack, lnIconToDraw 783 | lnIconMain = 0 784 | lnIconBack = 0 785 | 786 | IF VARTYPE(m.tnIcon) = "C" 787 | IF LEFT(ALLTRIM(m.tnIcon),1) = "," && GETWORDNUM fails if the 1st item is empty 788 | lcIconMain = "" 789 | lcIconBack = GETWORDNUM(m.tnIcon,1,",") 790 | ELSE 791 | lcIconMain = GETWORDNUM(m.tnIcon,1,",") 792 | IF FILEINDISK(m.lcIconMain) && We have a custom icon to load 793 | This._hExternalIcon = GetHIcon(m.lcIconMain) 794 | This._cExternalIconFile = m.lcIconMain 795 | ENDIF 796 | lcIconBack = LEFT(UPPER(GETWORDNUM(m.tnIcon,2,",")),1) 797 | ENDIF 798 | 799 | DO CASE 800 | CASE m.lcIconBack = "S" && Silver 801 | lnIconBack = -9 802 | CASE m.lcIconBack = "G" && Green 803 | lnIconBack = -8 804 | CASE m.lcIconBack = "R" && Red 805 | lnIconBack = -7 806 | CASE m.lcIconBack = "Y" && Yellow 807 | lnIconBack = -6 808 | CASE m.lcIconBack = "B" && Blue 809 | lnIconBack = -5 810 | CASE m.lcIconBack = "-" && Empty, no margin 811 | lnIconBack = 0 812 | OTHERWISE && Empty or Invalid 813 | lnIconBack = ICON_EMPTY 814 | ENDCASE 815 | 816 | 817 | IF VAL(m.lcIconMain) > 0 AND This._hExternalIcon = 0 818 | m.lnIconMain = VAL(m.lcIconMain) 819 | ELSE 820 | m.tnIcon = ALLTRIM(UPPER(m.tnIcon)) 821 | DO CASE 822 | CASE This._hExternalIcon > 0 823 | m.lnIconMain = ICON_EMPTY 824 | CASE m.tnIcon = "!4" && Warning 825 | m.lnIconMain = 1403 826 | CASE m.tnIcon = "!3" && Warning 827 | m.lnIconMain = 84 828 | CASE m.tnIcon = "!2" && Warning 829 | m.lnIconMain = -6 830 | CASE m.tnIcon = "!" && Warning 831 | m.lnIconMain = -1 832 | 833 | CASE m.tnIcon = "X5" && Error 834 | m.lnIconMain = 1402 835 | CASE m.tnIcon = "X4" && Error 836 | m.lnIconMain = 98 837 | CASE m.tnIcon = "X3" && Error 838 | m.lnIconMain = 89 839 | CASE m.tnIcon = "X2" && Error 840 | m.lnIconMain = -7 841 | CASE m.tnIcon = "X" && Error 842 | m.lnIconMain = -2 843 | 844 | CASE m.tnIcon = "I2" && Information 845 | m.lnIconMain = 81 846 | CASE m.tnIcon = "I" && Information 847 | m.lnIconMain = -3 848 | CASE m.tnIcon = "?2" && Question 849 | m.lnIconMain = 104 850 | CASE m.tnIcon = "?" && Question 851 | m.lnIconMain = 0x7f02 && IDI_QUESTION 852 | 853 | CASE m.tnIcon = "OK4" && Success 854 | m.lnIconMain = 1405 855 | CASE m.tnIcon = "OK3" && Success 856 | m.lnIconMain = 1400 857 | CASE m.tnIcon = "OK2" && Success 858 | m.lnIconMain = -8 && TD_SHIELD_OK_ICON 859 | CASE m.tnIcon = "OK" && Success 860 | m.lnIconMain = 106 861 | 862 | CASE m.tnIcon = "SHIELD" && Question 863 | m.lnIconMain = -4 864 | 865 | CASE m.tnIcon = "KEY2" && Key 866 | m.lnIconMain = 5360 && Key icon 867 | CASE m.tnIcon = "KEY" && Key 868 | m.lnIconMain = 82 && Key icon 869 | CASE m.tnIcon = "LOCK3" && Lock 870 | m.lnIconMain = 5381 && Lock icon 871 | CASE m.tnIcon = "LOCK2" && Lock 872 | m.lnIconMain = 1304 && Lock icon 873 | CASE m.tnIcon = "LOCK" && Lock 874 | m.lnIconMain = 59 && Lock icon 875 | CASE m.tnIcon = "ZIP" && Zip 876 | m.lnIconMain = 174 877 | 878 | CASE m.tnIcon = "SEARCH2" && Search 879 | m.lnIconMain = 5332 880 | CASE m.tnIcon = "SEARCH" && Search 881 | m.lnIconMain = 177 882 | 883 | CASE m.tnIcon = "USER2" && User 884 | m.lnIconMain = 5356 885 | CASE m.tnIcon = "USER" && User 886 | m.lnIconMain = 1029 887 | 888 | CASE m.tnIcon = "CLOUD2" && Cloud 889 | m.lnIconMain = 1404 890 | CASE m.tnIcon = "CLOUD" && Cloud 891 | m.lnIconMain = 1043 892 | 893 | CASE m.tnIcon = "STAR" 894 | m.lnIconMain = 1024 895 | CASE m.tnIcon = "FOLDER" 896 | m.lnIconMain = 1023 897 | 898 | CASE m.tnIcon = "MAIL" 899 | m.lnIconMain = 20 900 | CASE m.tnIcon = "CONNECT2" 901 | m.lnIconMain = 179 902 | CASE m.tnIcon = "CONNECT" 903 | m.lnIconMain = 25 904 | CASE m.tnIcon = "PRINTER2" 905 | m.lnIconMain = 45 906 | CASE m.tnIcon = "PRINTER" 907 | m.lnIconMain = 51 908 | CASE m.tnIcon = "CAMERA" 909 | m.lnIconMain = 57 910 | CASE m.tnIcon = "FILM" 911 | m.lnIconMain = 46 912 | CASE m.tnIcon = "FAX" 913 | m.lnIconMain = 76 914 | CASE m.tnIcon = "DOCUMENT" 915 | m.lnIconMain = 90 916 | CASE m.tnIcon = "SCAN" 917 | m.lnIconMain = 95 918 | CASE m.tnIcon = "COMPUTER2" 919 | m.lnIconMain = 149 920 | CASE m.tnIcon = "COMPUTER" 921 | m.lnIconMain = 109 922 | CASE m.tnIcon = "DIAGNOSE" 923 | m.lnIconMain = 150 924 | 925 | CASE m.tnIcon = "MUSIC" 926 | m.lnIconMain = 1026 927 | CASE m.tnIcon = "CANCEL" 928 | m.lnIconMain = 1027 929 | CASE m.tnIcon = "WRITE" 930 | m.lnIconMain = 5306 931 | CASE m.tnIcon = "PLAY" 932 | m.lnIconMain = 5341 933 | CASE m.tnIcon = "CLOCK" 934 | m.lnIconMain = 5368 935 | CASE m.tnIcon = "MOBILE" 936 | m.lnIconMain = 6400 937 | 938 | OTHERWISE 939 | m.lnIconMain = 0 940 | ENDCASE 941 | ENDIF 942 | 943 | ELSE 944 | m.lnIconMain = EVL(m.tnIcon, 0) && If passed no parameter or .F. 945 | ENDIF && IF VARTYPE(m.tnIcon) = "C" 946 | 947 | This.nIconMain = m.lnIconMain 948 | This.nIconBack = m.lnIconBack 949 | ENDPROC 950 | 951 | 952 | PROCEDURE ReplaceMainIcon 953 | LOCAL lcFmt, lhDialogInternal, lhEditBox, lhFont, lhParentHWnd, lnId, lhImage 954 | LOCAL dwExStyle, dwStyle, lhAppInstance, w1, h1, x1, y1, lcExt 955 | lhImage = This._hExternalIcon 956 | lhDialogInternal = This._hDialogUI 957 | 958 | x1 = 5 959 | y1 = 5 960 | w1 = 32 961 | h1 = 32 962 | lnId = 125 963 | 964 | #DEFINE SS_ICON 0x03 965 | #DEFINE SS_BITMAP 0x0E 966 | #DEFINE SS_WHITERECT 0x06 967 | #DEFINE SS_WHITEFRAME 0x09 968 | #DEFINE SS_CENTERIMAGE 0x200 969 | lcExt = UPPER(JUSTEXT(This._cExternalIconFile)) 970 | lnImgType = IIF(lcExt = "ICO", SS_ICON, SS_BITMAP) 971 | dwStyle = BITOR(WS_VISIBLE, WS_CHILD, lnImgType, SS_CENTERIMAGE) 972 | dwExStyle = 0 973 | 974 | * handle to application instance 975 | #DEFINE GWL_HINSTANCE -6 976 | lhParentHWnd = _Screen.HWnd 977 | lhAppInstance = GetWindowLong(lhParentHWnd, GWL_HINSTANCE) 978 | 979 | *!* HWND CreateWindowEx( 980 | *!* DWORD dwExStyle, // extended window style 981 | *!* LPCTSTR lpClassName, // registered class name 982 | *!* LPCTSTR lpWindowName, // window name 983 | *!* DWORD dwStyle, // window style 984 | *!* int x, // horizontal position of window 985 | *!* int y, // vertical position of window 986 | *!* int nWidth, // window width 987 | *!* int nHeight, // window height 988 | *!* HWND hWndParent, // handle to parent or owner window 989 | *!* HMENU hMenu, // menu handle or child identifier 990 | *!* HINSTANCE hInstance, // handle to application instance 991 | *!* LPVOID lpParam // window-creation data 992 | 993 | lhStatic = CreateWindowEx(dwExStyle, "STATIC", "", dwStyle, ; 994 | x1, y1, w1, h1, lhDialogInternal, lnId, lhAppInstance, 0) 995 | 996 | *!* * Test code for adding a static label control 997 | *!* dwStyle2 = BITOR(WS_VISIBLE, WS_CHILD) 998 | *!* lhStatic2 = CreateWindowEx(dwExStyle, "STATIC", "", dwStyle2, ; 999 | *!* x1, y1 + 30, w1 * 3, 22, lhDialogInternal, lnId + 10, lhAppInstance, 0) 1000 | *!* = SendMessageWText(lhStatic2, WM_SETTEXT, 0, TOUNICODE("TESTING LABEL")) 1001 | 1002 | #DEFINE STM_SETICON 0x170 1003 | #DEFINE STM_SETIMAGE 0x172 1004 | IF lhStatic > 0 1005 | DECLARE INTEGER GetDC IN user32 INTEGER 1006 | DECLARE INTEGER ReleaseDC IN user32 INTEGER, INTEGER 1007 | DECLARE INTEGER CreateSolidBrush IN WIN32API INTEGER 1008 | DECLARE INTEGER GetPixel IN WIN32API INTEGER, INTEGER, INTEGER 1009 | 1010 | #DEFINE BINDEVENTSEX_CALL_BEFORE 0x0001 1011 | #DEFINE BINDEVENTSEX_CALL_AFTER 0x0002 1012 | #DEFINE BINDEVENTSEX_RETURN_VALUE 0x0004 1013 | #DEFINE BINDEVENTSEX_NO_RECURSION 0x0008 1014 | #DEFINE BINDEVENTSEX_CLASSPROC 0x0010 1015 | 1016 | This._hStaticImage = m.lhStatic 1017 | * This._hStaticLabel = m.lhStatic2 1018 | 1019 | #DEFINE WM_CTLCOLORSTATIC 0x0138 1020 | BINDEVENTSEX(This._hDialogUI, WM_CTLCOLORSTATIC, This, 'WndProc3', "Hwnd, uMsg, wParam, lParam", BINDEVENTSEX_RETURN_VALUE) 1021 | IF lcExt = "ICO" 1022 | = SendMessageW(lhStatic, STM_SETIMAGE, IMAGE_ICON , lhImage) 1023 | ELSE 1024 | = SendMessageW(lhStatic, STM_SETIMAGE, IMAGE_BITMAP, lhImage) 1025 | ENDIF 1026 | ENDIF 1027 | ENDPROC 1028 | 1029 | 1030 | PROCEDURE WndProc3(thWnd, tnMessage, twParam, tlParam) 1031 | * ? thWnd, TRANSFORM(tnMessage, "@0"), twParam, tlParam 1032 | * ? "Static Image", This._hStaticImage 1033 | * ? "Static Label", This._hStaticLabel 1034 | IF NOT PEMSTATUS(This, "_nIconBackColor", 5) 1035 | LOCAL lnColor 1036 | This.AddProperty("_nIconBackColor", 0) 1037 | lhDC2 = GetWindowDC(This.hDialog) 1038 | lnColor = GetPixel(lhDC2, 3, 30) 1039 | This._nIconBackColor = lnColor 1040 | ENDIF 1041 | * LOCAL pOrgProc 1042 | * pOrgProc = xmbGetWindowLong(_VFP.HWnd, -4) 1043 | * = xmbCallWindowProc(pOrgProc, thWnd, tnMessage, twParam, tlParam) 1044 | LOCAL lnBackColor 1045 | DO CASE 1046 | CASE tlParam = This._hStaticImage 1047 | lnBackColor = This._nIconBackColor 1048 | CASE tlParam = This._hStaticLabel 1049 | lnBackColor = RGB(255,255,255) 1050 | OTHERWISE 1051 | lnBackColor = RGB(255,0,0) 1052 | ENDCASE 1053 | RETURN CreateSolidBrush(m.lnBackColor) 1054 | 1055 | 1056 | PROCEDURE CloseDialog 1057 | LOCAL lnPrevLastButton 1058 | m.lnPrevLastButton = This._nLastButton 1059 | * searching a command button to be virtually pressed 1060 | This.nXmbTimeout = -1 && Flag to tell we finished 1061 | LOCAL lhTarget 1062 | m.lhTarget = This.aButtonsHwnd(This.nDefaultBtn) 1063 | * simulates mouse click on the target button 1064 | = xmbSendMessage(m.lhTarget, WM_LBUTTONDOWN, 0, 0) 1065 | DOEVENTS && just in case 1066 | = xmbSendMessage(m.lhTarget, WM_LBUTTONUP, 0, 0) 1067 | This._nLastButton = m.lnPrevLastButton 1068 | ENDPROC 1069 | 1070 | 1071 | PROCEDURE UpdateIcon(tnIcon) 1072 | LOCAL lnIcon 1073 | lnIcon = EVL(tnIcon, This.nIconMain) 1074 | IF EMPTY(lnIcon) 1075 | lnIcon = ICON_EMPTY 1076 | ENDIF 1077 | lnIcon = BITAND(0x0000ffff, lnIcon) 1078 | =xmbSendMessage(This.hDialog, TDM_UPDATE_ICON, TDIE_ICON_MAIN, m.lnIcon) 1079 | RETURN 1080 | ENDPROC 1081 | 1082 | 1083 | FUNCTION SetButtonIcon(tnHwnd, tnModule, tnIndex) 1084 | LOCAL lhIco, lhModule 1085 | IF m.tnIndex < 100000 && Use ImageRes.Dll 1086 | IF This.hLibImageRes = 0 1087 | lhModule = LoadLibraryA("imageres.dll") 1088 | ELSE 1089 | lhModule = This.hLibImageRes 1090 | ENDIF 1091 | ELSE && Use Shell32.Dll 1092 | IF This.hLibShell32 = 0 1093 | lhModule = LoadLibraryA("shell32.dll") 1094 | * lhModule = LoadLibraryA("%SystemRoot%\system32\shell32.dll") 1095 | ELSE 1096 | lhModule = This.hLibShell32 1097 | ENDIF 1098 | tnIndex = tnIndex - 100000 && fix the correct index 1099 | ENDIF 1100 | lhIco = LoadImageA(lhModule, tnIndex, 1, 16, 16, 0) 1101 | =xmbSendMessage(tnHwnd, BM_SETIMAGE, 1, lhIco) 1102 | DestroyIcon(lhIco) 1103 | RETURN 1104 | ENDFUNC 1105 | 1106 | 1107 | PROCEDURE Destroy 1108 | IF This.hLibImageRes > 0 1109 | FreeLibrary(This.hLibImageRes) 1110 | ENDIF 1111 | IF This.hLibShell32 > 0 1112 | FreeLibrary(This.hLibShell32) 1113 | ENDIF 1114 | ENDPROC 1115 | 1116 | 1117 | PROCEDURE DialogCreated 1118 | IF EMPTY(This.nIconBack) AND This.lFakeTimeout = .T. AND This.nDialogType = 1 1119 | This.oTimer.Interval = 0 && No more need of this timer 1120 | ENDIF 1121 | 1122 | IF NOT EMPTY(This.nIconBack) AND This._lUpdatedIcon = .F. 1123 | This._lUpdatedIcon = .T. 1124 | This.UpdateIcon() 1125 | IF This.lFakeTimeout = .T. 1126 | This.oTimer.Interval = 0 1127 | ELSE 1128 | This.oTimer.Interval = This.nDefaultInterval 1129 | ENDIF 1130 | ENDIF 1131 | 1132 | IF This._hExternalIcon > 0 1133 | This.ReplaceMainIcon() 1134 | ENDIF 1135 | 1136 | LOCAL lhControl 1137 | IF This.nDialogType = 2 && Inputbox 1138 | This.AddTextBox() 1139 | This.oTimer.Interval = This.nDefaultInterval 1140 | lhControl = This._hEditBox 1141 | ENDIF 1142 | 1143 | IF INLIST(This.nDialogType,3,4,5,6) && Datebox 1144 | This.AddDateBox() 1145 | This.oTimer.Interval = This.nDefaultInterval 1146 | lhControl = This._hDateBox 1147 | ENDIF 1148 | 1149 | IF This.nDialogType > 1 1150 | This._hCustomControl = lhControl 1151 | && VFP2C32 BindEventsEx flags 1152 | #DEFINE BINDEVENTSEX_CALL_BEFORE 0x0001 1153 | #DEFINE BINDEVENTSEX_CALL_AFTER 0x0002 1154 | #DEFINE BINDEVENTSEX_RETURN_VALUE 0x0004 1155 | #DEFINE BINDEVENTSEX_NO_RECURSION 0x0008 1156 | #DEFINE BINDEVENTSEX_CLASSPROC 0x0010 1157 | * WM_SETFOCUS will give us the focused button 1158 | BINDEVENTSEX(This.aButtonsHwnd[1], WM_SETFOCUS , This, 'WndProc2') 1159 | BINDEVENTSEX(This.aButtonsHwnd[2], WM_SETFOCUS , This, 'WndProc2') 1160 | * WM_GETDLGCODE will give the key pressed on each control 1161 | * To handle the and keys 1162 | BINDEVENTSEX(m.lhControl, WM_GETDLGCODE, This, 'WndProc2') 1163 | BINDEVENTSEX(This.aButtonsHwnd[1], WM_GETDLGCODE, This, 'WndProc2') 1164 | BINDEVENTSEX(This.aButtonsHwnd[2], WM_GETDLGCODE, This, 'WndProc2') 1165 | ENDIF 1166 | ENDPROC 1167 | 1168 | 1169 | PROCEDURE AddTextBox 1170 | * About Edit controls 1171 | * https://docs.microsoft.com/en-us/windows/win32/controls/about-edit-controls#changing-the-formatting-rectangle 1172 | 1173 | LOCAL lcFmt, lhDialogInternal, lhEditBox, lhFont, lhParentHWnd, lnBottom, lnId, lnTop 1174 | LOCAL dwExStyle, dwStyle, h1, lhAppInstance, w1, x1, y1 1175 | lhDialogInternal = This._hDialogUI 1176 | 1177 | * Obtain the Dialog dimensions 1178 | LOCAL lnLeft, lnRight, lnWidth, lnHeight, lcRect 1179 | m.lcRect = REPLICATE(CHR(0),16) 1180 | =GetClientRect(lhDialogInternal, @m.lcRect) 1181 | m.lnLeft = CTOBIN(SUBSTR(m.lcRect, 1,4),"4RS") 1182 | m.lnRight = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS") 1183 | m.lnTop = CTOBIN(SUBSTR(m.lcRect, 5,4),"4RS") 1184 | m.lnBottom = CTOBIN(SUBSTR(m.lcRect,13,4),"4RS") 1185 | 1186 | m.lnWidth = m.lnRight - m.lnLeft 1187 | m.lnHeight = m.lnBottom - m.lnTop 1188 | 1189 | * ? "Dimensions", lnLeft, lnRight, lnTop, lnBottom, lnWidth, lnHeight 1190 | x1 = 45 1191 | y1 = lnHeight - 80 1192 | w1 = lnWidth - x1 - x1 1193 | h1 = 21 1194 | lnId = 110 1195 | dwStyle = BITOR(WS_VISIBLE, WS_CHILD, WS_TABSTOP, ES_LEFT, ES_AUTOHSCROLL,ES_NOHIDESEL) && WS_BORDER 1196 | 1197 | lcFmt = This._cEditBoxFmt && !U=ES_UPPERCASE, DI=ES_NUMERIC, P=ES_PASSWORD, L=ES_LOWERCASE 1198 | IF "!" $ lcFmt OR "U" $ lcFmt 1199 | dwStyle = BITOR(dwStyle, ES_UPPERCASE) 1200 | ENDIF 1201 | IF "D" $ lcFmt OR "I" $ lcFmt 1202 | dwStyle = BITOR(dwStyle, ES_NUMBER) 1203 | ENDIF 1204 | IF "L" $ lcFmt 1205 | dwStyle = BITOR(dwStyle, ES_LOWERCASE) 1206 | ENDIF 1207 | IF "P" $ lcFmt 1208 | dwStyle = BITOR(dwStyle, ES_PASSWORD) && Displays an asterisk (*) for each character typed into the edit control. 1209 | && This style is valid only for single-line edit controls. 1210 | && To change the characters that is displayed, or set or clear this style, use the EM_SETPASSWORDCHAR message. 1211 | ENDIF 1212 | 1213 | dwExStyle = BITOR(WS_EX_CLIENTEDGE,0) && ,WS_EX_CONTROLPARENT) && Sunken edge 1214 | 1215 | * handle to application instance 1216 | #DEFINE GWL_HINSTANCE -6 1217 | lhParentHWnd = _Screen.HWnd 1218 | lhAppInstance = GetWindowLong(lhParentHWnd, GWL_HINSTANCE) 1219 | 1220 | *!* HWND CreateWindowEx( 1221 | *!* DWORD dwExStyle, // extended window style 1222 | *!* LPCTSTR lpClassName, // registered class name 1223 | *!* LPCTSTR lpWindowName, // window name 1224 | *!* DWORD dwStyle, // window style 1225 | *!* int x, // horizontal position of window 1226 | *!* int y, // vertical position of window 1227 | *!* int nWidth, // window width 1228 | *!* int nHeight, // window height 1229 | *!* HWND hWndParent, // handle to parent or owner window 1230 | *!* HMENU hMenu, // menu handle or child identifier 1231 | *!* HINSTANCE hInstance, // handle to application instance 1232 | *!* LPVOID lpParam // window-creation data 1233 | lhEditBox = CreateWindowEx(dwExStyle, "Edit", This._cDefaultInput, ; 1234 | dwStyle, x1, y1, w1, h1, lhDialogInternal, lnId, lhAppInstance, 0) 1235 | 1236 | #DEFINE DEFAULT_GUI_FONT 17 1237 | #DEFINE OUT_OUTLINE_PRECIS 8 1238 | #DEFINE CLIP_STROKE_PRECIS 2 1239 | #DEFINE PROOF_QUALITY 2 1240 | lhFont = GetStockObject(DEFAULT_GUI_FONT) 1241 | IF lhFont > 0 1242 | SendMessageW(lhEditBox, WM_SETFONT, lhFont, 0) 1243 | ENDIF 1244 | This._hEditBox = lhEditBox 1245 | =SetFocus(lhEditBox) 1246 | SendMessageW(lhEditBox, EM_SETSEL, 0, -1) 1247 | ENDPROC 1248 | 1249 | 1250 | PROCEDURE AddDateBox 1251 | 1252 | * About Date and Time picker 1253 | * https://docs.microsoft.com/en-us/windows/win32/controls/date-and-time-picker-control-reference 1254 | LOCAL lcDefaultDate, lhDateTime, lhDateTime0, lhDialogInternal, lhFont, lhParentHWnd, lhTime 1255 | LOCAL lnBorder, lnBottom, lnHOffset, lnId, lnTop 1256 | LOCAL dwExStyle, dwStyle, h1, h2, lhAppInstance, w1, w2, x1, x2, y1, y2 1257 | lhDialogInternal = This._hDialogUI 1258 | 1259 | * Obtain the Dialog dimensions 1260 | LOCAL lnLeft, lnRight, lnWidth, lnHeight, lcRect 1261 | m.lcRect = REPLICATE(CHR(0),16) 1262 | =GetClientRect(lhDialogInternal, @m.lcRect) 1263 | m.lnLeft = CTOBIN(SUBSTR(m.lcRect, 1,4),"4RS") 1264 | m.lnRight = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS") 1265 | m.lnTop = CTOBIN(SUBSTR(m.lcRect, 5,4),"4RS") 1266 | m.lnBottom = CTOBIN(SUBSTR(m.lcRect,13,4),"4RS") 1267 | 1268 | m.lnWidth = m.lnRight - m.lnLeft 1269 | m.lnHeight = m.lnBottom - m.lnTop 1270 | 1271 | * ? "Dimensions", lnLeft, lnRight, lnTop, lnBottom, lnWidth, lnHeight 1272 | lnId = 110 1273 | 1274 | * Enum DTSTYLES 1275 | * https://docs.microsoft.com/en-us/windows/win32/controls/date-and-time-picker-control-styles 1276 | #DEFINE DTS_SHORTDATEFORMAT 0x00 1277 | #DEFINE DTS_UPDOWN 0x01 1278 | #DEFINE DTS_SHOWNONE 0x02 1279 | #DEFINE DTS_LONGDATEFORMAT 0x04 1280 | #DEFINE DTS_TIMEFORMAT 0x09 1281 | #DEFINE DTS_APPCANPARSE 0x10 1282 | #DEFINE DTS_RIGHTALIGN 0x20 1283 | #DEFINE DTS_SHORTDATECENTURYFORMAT 0x0C 1284 | 1285 | * handle to application instance 1286 | #DEFINE GWL_HINSTANCE -6 1287 | lhParentHWnd = _Screen.HWnd 1288 | lhAppInstance = GetWindowLong(lhParentHWnd, GWL_HINSTANCE) 1289 | 1290 | * http://chokuto.ifdef.jp/advanced/function/CreateWindowEx.html && CreateWindowEx 1291 | *!* HWND CreateWindowEx( 1292 | *!* DWORD dwExStyle, // extended window style 1293 | *!* LPCTSTR lpClassName, // registered class name 1294 | *!* LPCTSTR lpWindowName, // window name 1295 | *!* DWORD dwStyle, // window style 1296 | *!* int x, // horizontal position of window 1297 | *!* int y, // vertical position of window 1298 | *!* int nWidth, // window width 1299 | *!* int nHeight, // window height 1300 | *!* HWND hWndParent, // handle to parent or owner window 1301 | *!* HMENU hMenu, // menu handle or child identifier 1302 | *!* HINSTANCE hInstance, // handle to application instance 1303 | *!* LPVOID lpParam // window-creation data 1304 | 1305 | dwStyle = BITOR(WS_CHILD, WS_OVERLAPPED, WS_VISIBLE, DTS_SHORTDATEFORMAT) && Original 1306 | dwExStyle = BITOR(WS_EX_CLIENTEDGE, WS_EX_LEFT, WS_EX_LTRREADING, WS_EX_RIGHTSCROLLBAR) 1307 | 1308 | IF EMPTY(This._dDefaultDateTime) 1309 | lcDefaultDate = This.GetDateTimeBuf(This._dDefaultDate) 1310 | ELSE 1311 | lcDefaultDate = This.GetDateTimeBuf(This._dDefaultDateTime) 1312 | ENDIF 1313 | 1314 | lhDateTime = 0 1315 | lhTime = 0 1316 | 1317 | DO CASE 1318 | CASE This.nDialogType = 3 && Date 1319 | x1 = 115 1320 | y1 = lnHeight - 80 1321 | w1 = lnWidth - x1 - x1 1322 | h1 = 21 1323 | lhDateTime = CreateWindowEx(m.dwExStyle, "SysDateTimePick32", "", ; 1324 | dwStyle, x1, y1, w1, h1, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1325 | 1326 | 1327 | CASE This.nDialogType = 4 && DateTime 1328 | lnBorder = 45 1329 | w1 = 120 1330 | w2 = 80 1331 | lnHOffset = FLOOR((lnWidth - lnBorder - lnBorder - w1 - w2) / 3) 1332 | 1333 | x1 = lnBorder + lnHOffset 1334 | y1 = lnHeight - 80 1335 | h1 = 21 1336 | 1337 | x2 = x1 + w1 + lnHOffset 1338 | y2 = y1 1339 | h2 = h1 1340 | 1341 | lhDateTime = CreateWindowEx(m.dwExStyle, "SysDateTimePick32", "", ; 1342 | dwStyle, x1, y1, w1, h1, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1343 | 1344 | dwStyle = BITOR(WS_CHILD, WS_OVERLAPPED, WS_VISIBLE, DTS_TIMEFORMAT) && Time 1345 | lhTime = CreateWindowEx(m.dwExStyle, "SysDateTimePick32", "", ; 1346 | dwStyle, x2, y2, w2, h2, m.lhDialogInternal, lnId + 1, m.lhAppInstance, 0) 1347 | 1348 | 1349 | CASE This.nDialogType = 5 && Month calendar 1350 | 1351 | * MCM_GETMINREQRECT 1352 | * retrieves the minimum size required to display a full month in a month calendar control. 1353 | * Size information is presented in the form of a RECT structure. 1354 | * Parameters 1355 | * - wParam - Not used. 1356 | * - lpRectInfo - Long pointer to a RECT structure that receives bounding rectangle information. 1357 | 1358 | * First, create a fake object (the Taskdialog API does not let "SetWindowPos" to reposition 1359 | lhDateTime0 = CreateWindowEx(m.dwExStyle, "SysMonthCal32", "", ; 1360 | WS_CHILD, 1, 1, 1, 1, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1361 | 1362 | LOCAL lnObjWidth, lnObjHeight, lcRect 1363 | m.lcRect = REPLICATE(CHR(0),16) 1364 | SendMessageWText(lhDateTime0, MCM_GETMINREQRECT, 0, @lcRect) 1365 | m.lnObjWidth = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS") 1366 | m.lnObjHeight = CTOBIN(SUBSTR(m.lcRect,13,4),"4RS") 1367 | 1368 | x1 = FLOOR((lnWidth - lnObjWidth) / 2) 1369 | y1 = lnHeight - 55 - lnObjHeight 1370 | 1371 | * Finally, create the definitive object, at the desired position 1372 | * SYSMONTHCAL32 references 1373 | * http://svn.vdf-guidance.com/cWindowsEx/trunk/cWindowsEx/cWindowsEx%20Library/AppSrc/cMonthCal.h 1374 | * http://svn.vdf-guidance.com/Crossmerge/trunk/CMOS/AppSrc/cMonthCalendar.h && Header 1375 | dwStyle = BITOR(WS_CHILD, WS_OVERLAPPED, WS_VISIBLE, DTS_SHORTDATEFORMAT,WS_CLIPCHILDREN,WS_CLIPSIBLINGS) && Original 1376 | 1377 | lhDateTime = CreateWindowEx(m.dwExStyle, "SysMonthCal32", "", ; 1378 | dwStyle, x1, y1, lnObjWidth, lnObjHeight, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1379 | 1380 | 1381 | CASE This.nDialogType = 6 && Month date range 1382 | 1383 | #DEFINE MCS_MULTISELECT 2 1384 | #DEFINE MCS_NOSELCHANGEONNAV 0x0100 1385 | #DEFINE MCS_SHORTDAYSOFWEEK 0x0080 1386 | 1387 | * First, create a fake object (the Taskdialog API does not let "SetWindowPos" to reposition 1388 | * To make it fit in the dialog, we reduce the calendar width using MCS_SHORTDAYSOFWEEK 1389 | lhDateTime0 = CreateWindowEx(m.dwExStyle, "SysMonthCal32", "", ; 1390 | WS_CHILD + MCS_SHORTDAYSOFWEEK, 1, 1, 1, 1, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1391 | 1392 | LOCAL lnObjWidth, lnObjHeight, lcRect 1393 | m.lcRect = REPLICATE(CHR(0),16) 1394 | SendMessageWText(lhDateTime0, MCM_GETMINREQRECT, 0, @lcRect) 1395 | m.lnObjWidth = CTOBIN(SUBSTR(m.lcRect, 9,4),"4RS") 1396 | m.lnObjHeight = CTOBIN(SUBSTR(m.lcRect,13,4),"4RS") 1397 | 1398 | 1399 | * Finally, create the definitive object, at the desired position 1400 | * SYSMONTHCAL32 references 1401 | * http://svn.vdf-guidance.com/cWindowsEx/trunk/cWindowsEx/cWindowsEx%20Library/AppSrc/cMonthCal.h 1402 | * http://svn.vdf-guidance.com/Crossmerge/trunk/CMOS/AppSrc/cMonthCalendar.h && Header 1403 | dwStyle = BITOR(WS_CHILD, WS_OVERLAPPED, WS_VISIBLE, DTS_SHORTDATEFORMAT,WS_CLIPCHILDREN,WS_CLIPSIBLINGS) && Original 1404 | 1405 | #DEFINE MCS_MULTISELECT 2 1406 | #DEFINE MCS_NOSELCHANGEONNAV 0x0100 1407 | #DEFINE MCS_SHORTDAYSOFWEEK 0x0080 1408 | m.lnObjWidth = (m.lnObjWidth * 2) - 6 && fit 2 calendars 1409 | x1 = FLOOR((lnWidth - lnObjWidth) / 2) 1410 | y1 = lnHeight - 55 - lnObjHeight 1411 | dwStyle = dwStyle + MCS_MULTISELECT + MCS_NOSELCHANGEONNAV + MCS_SHORTDAYSOFWEEK 1412 | 1413 | lhDateTime = CreateWindowEx(m.dwExStyle, "SysMonthCal32", "", ; 1414 | dwStyle, x1, y1, lnObjWidth, lnObjHeight, m.lhDialogInternal, lnId, m.lhAppInstance, 0) 1415 | 1416 | SendMessageW(lhDateTime, MCM_SETMAXSELCOUNT, 366, 0) && Maximum range is one year 1417 | OTHERWISE 1418 | 1419 | ENDCASE 1420 | 1421 | IF NOT EMPTY(lhTime) 1422 | lhFont = GetStockObject(DEFAULT_GUI_FONT) 1423 | IF lhFont > 0 1424 | SendMessageW(lhTime, WM_SETFONT, lhFont, 0) 1425 | ENDIF 1426 | * Store the current date and time to the 2nd object as well 1427 | =SendMessageWText(lhTime, DTM_SETSYSTEMTIME, 0, lcDefaultDate) 1428 | This._hTimeBox = lhTime 1429 | ENDIF 1430 | 1431 | IF NOT EMPTY(lhDateTime) 1432 | lhFont = GetStockObject(DEFAULT_GUI_FONT) 1433 | IF lhFont > 0 1434 | SendMessageW(lhDateTime, WM_SETFONT, lhFont, 0) 1435 | ENDIF 1436 | 1437 | * Store the current date 1438 | =SendMessageWText(lhDateTime, DTM_SETSYSTEMTIME, 0, lcDefaultDate) 1439 | This._hDateBox = lhDateTime 1440 | =SetFocus(lhDateTime) 1441 | ENDIF 1442 | ENDPROC 1443 | 1444 | 1445 | PROCEDURE UpdateText 1446 | LOCAL lcBuf, lnPos1, lnPos2, lqSel 1447 | IF This._hEditBox <> 0 1448 | lqSel = SendMessageW(This._hEditBox, EM_GETSEL, 0, 0) 1449 | lcBuf = BINTOC(lqSel,"4RS") 1450 | lnPos1 = CTOBIN(LEFT(lcBuf,2),"2RS") 1451 | lnPos2 = CTOBIN(SUBSTR(lcBuf,3),"2RS") 1452 | 1453 | LOCAL lnLen as Integer, lcText as String 1454 | lnLen = SendMessageW(This._hEditBox, WM_GETTEXTLENGTH, 0, 0) * 2 1455 | IF lnLen > 0 THEN 1456 | lcText = SPACE(lnLen) + CHR(0) 1457 | SendMessageWText(This._hEditBox, WM_GETTEXT, lnLen + 1, @lcText) 1458 | lcText = STRCONV(m.lcText, 6) && FromUnicode 1459 | 1460 | * Validate the text 1461 | DO CASE 1462 | CASE "N" $ This._cEditBoxFmt 1463 | * The inner CHRTRAN() function removes anything that is a number. The return value is 1464 | * what will be removed in the outer CHRTRAN function. 1465 | * The accepted values 1466 | LOCAL lcAccepted, lcDigitsOnly, lcPoint 1467 | m.lcPoint = This._SetPoint 1468 | m.lcAccepted = This._cEditBoxNumeric && "-0123456789." 1469 | m.lcDigitsOnly = CHRTRAN(m.lcText, CHRTRAN(m.lcText, m.lcAccepted, SPACE(0)), SPACE(0)) 1470 | m.lcDigitsOnly = STRTRAN(m.lcDigitsOnly, lcPoint, "", 2, 9) 1471 | m.lcDigitsOnly = STRTRAN(m.lcDigitsOnly, "-" , "", 2, 9) 1472 | IF AT("-", m.lcDigitsOnly) > 1 1473 | m.lcDigitsOnly = STRTRAN(m.lcDigitsOnly, "-", "", 1, 9) 1474 | ENDIF 1475 | IF m.lcDigitsOnly <> lcText && Update the input 1476 | m.lcDigitsOnly = TOUNICODE(m.lcDigitsOnly) + CHR(0) 1477 | =xmbSetWindowTextZ(This._hEditBox, m.lcDigitsOnly) && Update the contents 1478 | 1479 | * Since we excluded the intruder character, we need to reposition the Caret cursor 1480 | lnPos2 = MAX(0, lnPos2-1) && Back one character 1481 | SendMessageW(This._hEditBox, EM_SETSEL, lnPos2, lnPos2) 1482 | ENDIF 1483 | OTHERWISE 1484 | ENDCASE 1485 | 1486 | ENDIF 1487 | This._cInputText = m.lcText 1488 | ENDIF 1489 | ENDPROC 1490 | 1491 | 1492 | PROCEDURE UpdateDate 1493 | LOCAL lnRet 1494 | IF This._hDateBox = 0 1495 | RETURN 1496 | ENDIF 1497 | 1498 | LOCAL lcDate as String, lcDate2, ltDateTime, ldDate, ldDate2 1499 | IF This.nDialogType = 6 && Date range 1500 | lcDate = REPLICATE(CHR(0),32) 1501 | lnRet = SendMessageWText(This._hDateBox, MCM_GETSELRANGE, 0, @lcDate) 1502 | 1503 | ltDateTime = This.GetDateTime(LEFT(lcDate,16)) 1504 | ldDate = TTOD(m.ltDateTime) 1505 | This._dInputDate = m.ldDate 1506 | 1507 | ltDateTime = This.GetDateTime(SUBSTR(lcDate,17,16)) 1508 | ldDate2 = TTOD(m.ltDateTime) 1509 | This._dInputDate2 = m.ldDate2 1510 | RETURN 1511 | ENDIF 1512 | 1513 | lcDate = REPLICATE(CHR(0),16) 1514 | SendMessageWText(This._hDateBox, DTM_GETSYSTEMTIME, 0, @lcDate) 1515 | 1516 | IF This._hTimeBox > 0 && having the time control, we need to merge both controls information 1517 | lcDate2 = REPLICATE(CHR(0),16) 1518 | SendMessageWText(This._hTimeBox, DTM_GETSYSTEMTIME, 0, @lcDate2) 1519 | lcDate = LEFT(lcDate, 8) + SUBSTR(lcDate2, 9, 6) && Merged the Date part with the time from the 2nd control 1520 | ENDIF 1521 | 1522 | ltDateTime = This.GetDateTime(lcDate) 1523 | ldDate = TTOD(m.ltDateTime) 1524 | This._dInputDate = m.ldDate 1525 | This._tInputDateTime = m.ltDateTime 1526 | 1527 | * SystemTime structure 1528 | * https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-systemtime 1529 | *!* typedef struct _SYSTEMTIME { 1530 | *!* WORD wYear; 1531 | *!* WORD wMonth; 1532 | *!* WORD wDayOfWeek; 1533 | *!* WORD wDay; 1534 | *!* WORD wHour; 1535 | *!* WORD wMinute; 1536 | *!* WORD wSecond; 1537 | *!* WORD wMilliseconds; 1538 | *!* } SYSTEMTIME, *PSYSTEMTIME, *LPSYSTEMTIME 1539 | ENDPROC 1540 | 1541 | PROCEDURE GetDateTime(tcBuffer) 1542 | 1543 | * ? tcBuffer, LEN(tcBuffer), EMPTY(tcBuffer) 1544 | IF VARTYPE(tcBuffer) <> "C" 1545 | RETURN .F. 1546 | ENDIF 1547 | LOCAL ltDateTime 1548 | TRY 1549 | m.ltDateTime = DATETIME(CTOBIN(SUBSTR(tcBuffer,1,2),"2RS"), ; && Year 1550 | CTOBIN(SUBSTR(tcBuffer,3,2),"2RS"), ; && Month 1551 | CTOBIN(SUBSTR(tcBuffer,7,2),"2RS"), ; && Day 1552 | CTOBIN(SUBSTR(tcBuffer,9,2),"2RS"), ; && Hour 1553 | CTOBIN(SUBSTR(tcBuffer,11,2),"2RS"), ; && Minute 1554 | CTOBIN(SUBSTR(tcBuffer,13,2),"2RS")) && Seconds 1555 | CATCH 1556 | m.ltDateTime = {//::} 1557 | ENDTRY 1558 | 1559 | RETURN m.ltDateTime 1560 | 1561 | PROCEDURE GetDateTimeBuf(tdDate) 1562 | RETURN BINTOC(YEAR(m.tdDate),"2RS") + ; && Year 1563 | BINTOC(MONTH(m.tdDate),"2RS") + ; && Month 1564 | BINTOC(DOW(m.tdDate),"2RS") + ; && Day of week 1565 | BINTOC(DAY(m.tdDate),"2RS") + ; && Day 1566 | BINTOC(HOUR(m.tdDate),"2RS") + ; && Hour 1567 | BINTOC(MINUTE(m.tdDate),"2RS") + ; && Minute 1568 | BINTOC(SEC(m.tdDate),"2RS") && Seconds 1569 | 1570 | PROCEDURE WndProc2(thWnd, tnMessage, twParam, tlParam) 1571 | * ? thWnd, TRANSFORM(tnMessage, "@0"), twParam, tlParam 1572 | * ? 1,GetWinText(thWND) 1573 | * ? 2,GetWinText(tnMessage) 1574 | 1575 | LOCAL lnBtnId 1576 | m.lnBtnId = This.GetButtonIdFromWwnd(thWnd) 1577 | 1578 | DO CASE 1579 | CASE m.tnMessage = WM_SETFOCUS 1580 | This._nLastButton = m.lnBtnId 1581 | 1582 | CASE m.tnMessage = WM_GETDLGCODE AND twParam = 27 && ESC 1583 | This._nLastButton = 2 1584 | This.CloseDialog() 1585 | 1586 | * Focus the editbox 1587 | CASE m.tnMessage = WM_GETDLGCODE AND twParam = 9 AND m.lnBtnId = 2 && TAB 1588 | SetFocus(This._hCustomControl) 1589 | IF This.nDialogType = 2 && INPUTBOX - select the whole string 1590 | SendMessageW(This._hEditBox, EM_SETSEL, 0, -1) 1591 | ENDIF 1592 | 1593 | * Unfocus the editbox if the focus is at "Cancel" 1594 | CASE m.tnMessage = WM_GETDLGCODE AND twParam = 9 AND m.thWnd = This._hEditBox && TAB 1595 | IF This.nDialogType = 2 && INPUTBOX - select the whole string 1596 | SendMessageW(This._hEditBox, EM_SETSEL, 0, 0) 1597 | ENDIF 1598 | 1599 | OTHERWISE 1600 | ENDCASE 1601 | ENDPROC 1602 | 1603 | 1604 | FUNCTION GetButtonIdFromWwnd(tnHwnd) 1605 | * Having the hWnd, we get the button 1606 | LOCAL n, lnID 1607 | lnId = 0 1608 | FOR n = 1 TO ALEN(This.aButtonsHwnd,1) 1609 | IF This.aButtonsHwnd(n) = m.tnHwnd 1610 | lnId = n 1611 | EXIT 1612 | ENDIF 1613 | ENDFOR 1614 | RETURN lnId 1615 | ENDFUNC 1616 | 1617 | ENDDEFINE 1618 | 1619 | 1620 | ********************************************************************* 1621 | FUNCTION xmbGetWindowText(HWND, lpString, nMaxCount)&& (hWnd, @lpString, nMaxCount) 1622 | ********************************************************************* 1623 | DECLARE INTEGER GetWindowText IN user32 ; 1624 | AS xmbGetWindowText ; 1625 | INTEGER HWND, STRING @lpString, INTEGER nMaxCount 1626 | RETURN xmbGetWindowText(m.HWND, @m.lpString, m.nMaxCount) 1627 | ENDFUNC 1628 | 1629 | ********************************************************************* 1630 | FUNCTION xmbEnableWindow(HWND, fEnable) 1631 | ********************************************************************* 1632 | DECLARE INTEGER EnableWindow IN user32 AS xmbEnablewindow INTEGER HWND, INTEGER fEnable 1633 | RETURN xmbEnableWindow(m.HWND, m.fEnable) 1634 | ENDFUNC 1635 | 1636 | ********************************************************************* 1637 | FUNCTION xmbSendMessage(hwindow, msg, wParam, LPARAM) 1638 | ********************************************************************* 1639 | * http://msdn.microsoft.com/en-us/library/bb760780(vs.85).aspx 1640 | * http://www.news2news.com/vfp/?group=-1&function=312 1641 | DECLARE INTEGER SendMessage IN user32 AS xmbsendmessage ; 1642 | INTEGER hwindow, INTEGER msg, ; 1643 | INTEGER wParam, INTEGER LPARAM 1644 | RETURN xmbSendMessage(m.hwindow, m.msg, m.wParam, m.LPARAM) 1645 | ENDFUNC 1646 | 1647 | 1648 | ********************************************************************* 1649 | FUNCTION xmbPostMessage(hwindow, msg, wParam, LPARAM) 1650 | ********************************************************************* 1651 | * http://msdn.microsoft.com/en-us/library/bb760780(vs.85).aspx 1652 | * http://www.news2news.com/vfp/?group=-1&function=312 1653 | DECLARE INTEGER PostMessage IN user32 AS xmbPostMessage ; 1654 | INTEGER hwindow, INTEGER msg, ; 1655 | INTEGER wParam, INTEGER LPARAM 1656 | RETURN xmbPostMessage(m.hwindow, m.msg, m.wParam, m.LPARAM) 1657 | ENDFUNC 1658 | 1659 | 1660 | 1661 | ********************************************************************* 1662 | FUNCTION xmbDeleteObject(hobject) 1663 | ********************************************************************* 1664 | DECLARE INTEGER DeleteObject IN gdi32 AS xmbdeleteobject INTEGER hobject 1665 | RETURN xmbDeleteObject(m.hobject) 1666 | ENDFUNC 1667 | 1668 | ********************************************************************* 1669 | FUNCTION xmbCallWindowProc(lpPrevWndFunc, nhWnd, uMsg, wParam, LPARAM) 1670 | ********************************************************************* 1671 | DECLARE LONG CallWindowProc IN User32 ; 1672 | AS xmbCallWindowProc ; 1673 | LONG lpPrevWndFunc, LONG nhWnd, ; 1674 | LONG uMsg, LONG wParam, LONG LPARAM 1675 | 1676 | RETURN xmbCallWindowProc(m.lpPrevWndFunc, m.nhWnd, m.uMsg, m.wParam, m.LPARAM) 1677 | ENDFUNC 1678 | 1679 | ********************************************************************* 1680 | FUNCTION xmbGetWindowLong(nhWnd, nIndex) 1681 | ********************************************************************* 1682 | DECLARE LONG GetWindowLong IN User32 ; 1683 | AS xmbGetWindowLong ; 1684 | LONG nhWnd, INTEGER nIndex 1685 | RETURN xmbGetWindowLong(m.nhWnd, m.nIndex) 1686 | ENDFUNC 1687 | 1688 | *!* ********************************************************************* 1689 | *!* FUNCTION xmbTaskDialog(hWndParent, hInstance, pszWindowTitle, pszMainInstruction, pszContent, dwCommonButtons, pszIcon, pnButton) 1690 | *!* ********************************************************************* 1691 | *!* DECLARE SHORT TaskDialog IN comctl32 ; 1692 | *!* AS xmbTaskDialog ; 1693 | *!* INTEGER hWndParent, INTEGER hInstance, ; 1694 | *!* STRING pszWindowTitle, STRING pszMainInstruction, ; 1695 | *!* STRING pszContent, INTEGER dwCommonButtons, ; 1696 | *!* INTEGER pszIcon, INTEGER @pnButton 1697 | *!* RETURN xmbTaskDialog(m.hWndParent, m.hInstance, m.pszWindowTitle, m.pszMainInstruction, m.pszContent, m.dwCommonButtons, m.pszIcon, m.pnButton) 1698 | 1699 | ********************************************************************* 1700 | FUNCTION xmbGetWindow(HWND, wFlag) 1701 | ********************************************************************* 1702 | DECLARE INTEGER GetWindow IN user32 ; 1703 | AS xmbGetWindow ; 1704 | INTEGER HWND, INTEGER wFlag 1705 | RETURN xmbGetWindow(m.HWND, m.wFlag) 1706 | 1707 | ********************************************************************* 1708 | FUNCTION xmbIsWindow(hWnd) 1709 | ********************************************************************* 1710 | DECLARE INTEGER IsWindow IN user32 ; 1711 | AS xmbIsWindow ; 1712 | INTEGER hwnd 1713 | RETURN xmbIsWindow(hWnd) 1714 | 1715 | ********************************************************************* 1716 | FUNCTION GetWinText(hwindow) 1717 | ********************************************************************* 1718 | LOCAL cBuffer 1719 | m.cBuffer = REPLICATE(CHR(0), 255) 1720 | = xmbGetWindowText(m.hwindow, @m.cBuffer, LEN(m.cBuffer)) 1721 | RETURN STRTRAN(m.cBuffer, CHR(0), "") 1722 | ENDFUNC 1723 | 1724 | ********************************************************************* 1725 | FUNCTION xmbSetWindowText(HWND, lpString) 1726 | ********************************************************************* 1727 | DECLARE INTEGER SetWindowText IN user32 ; 1728 | AS xmbSetWindowText ; 1729 | INTEGER HWND, STRING lpString 1730 | RETURN xmbSetWindowText(m.HWND, m.lpString) 1731 | ENDFUNC 1732 | 1733 | ********************************************************************* 1734 | FUNCTION xmbSetWindowTextZ(HWND, lpString) && For Unicodes 1735 | ********************************************************************* 1736 | DECLARE INTEGER SetWindowTextW IN user32 ; 1737 | AS xmbSetWindowTextZ ; 1738 | INTEGER HWND, STRING lpString 1739 | RETURN xmbSetWindowTextZ(m.HWND, m.lpString) 1740 | ENDFUNC 1741 | 1742 | 1743 | ********************************************************************* 1744 | FUNCTION SetWinText(hwindow, tcText) 1745 | ********************************************************************* 1746 | = xmbSetWindowText(m.hwindow, m.tcText + CHR(0)) 1747 | RETURN 1748 | ENDFUNC 1749 | 1750 | ********************************************************************* 1751 | FUNCTION xmbRealGetWindowClass(hwindow, pszType, cchType) 1752 | ********************************************************************* 1753 | DECLARE INTEGER RealGetWindowClass IN user32 ; 1754 | AS xmbRealGetWindowClass ; 1755 | INTEGER hWindow, STRING @ pszType, ; 1756 | INTEGER cchType 1757 | RETURN xmbRealGetWindowClass(m.hwindow, m.pszType, m.cchType) 1758 | ENDFUNC 1759 | 1760 | ********************************************************************* 1761 | FUNCTION GetWindowClass(lnWindow) 1762 | ********************************************************************* 1763 | LOCAL lnLength, lcText 1764 | m.lcText = SPACE(250) 1765 | m.lnLength = xmbRealGetWindowClass(m.lnWindow, ; 1766 | @m.lcText, LEN(m.lcText)) 1767 | RETURN IIF(m.lnLength > 0, ; 1768 | LEFT(m.lcText, m.lnLength), "#empty#") 1769 | ENDFUNC 1770 | 1771 | ********************************************************************* 1772 | FUNCTION xmbFindWindowEx(hWndParent, hwndChildAfter, lpszClass, lpszWindow) 1773 | ********************************************************************* 1774 | DECLARE INTEGER FindWindowEx IN user32 ; 1775 | AS xmbFindWindowEx ; 1776 | INTEGER hwndParent, INTEGER hwndChildAfter, ; 1777 | STRING @lpszClass, STRING @lpszWindow 1778 | RETURN xmbFindWindowEx(m.hWndParent, m.hwndChildAfter, m.lpszClass, m.lpszWindow) 1779 | ENDFUNC 1780 | 1781 | ********************************************************************* 1782 | FUNCTION xmbGetSystemMenu(HWnd, bRevert) 1783 | ********************************************************************* 1784 | DECLARE INTEGER GetSystemMenu In User32 ; 1785 | AS xmbGetSystemMenu ; 1786 | INTEGER HWnd, INTEGER bRevert 1787 | RETURN xmbGetSystemMenu(HWnd, bRevert) 1788 | ENDFUNC 1789 | 1790 | ********************************************************************* 1791 | FUNCTION xmbEnableMenuItem(hMenu, wIDEnableItem, wEnable) 1792 | ********************************************************************* 1793 | DECLARE INTEGER EnableMenuItem IN User32 ; 1794 | AS xmbEnableMenuItem ; 1795 | LONG hMenu, LONG wIDEnableItem, LONG wEnable 1796 | RETURN xmbEnableMenuItem(hMenu, wIDEnableItem, wEnable) 1797 | ENDFUNC 1798 | 1799 | 1800 | ********************************************************************* 1801 | * The timer class controls the timeout parameter 1802 | DEFINE CLASS xmbTimer as Timer 1803 | * Interval is in milliseconds. 1804 | * To get 5 seconds -> 5 seconds * 1000 1805 | Interval = 0 1806 | Enabled = .F. 1807 | nCurrentTimeout = 0 1808 | lStarted = .F. 1809 | PROCEDURE Timer 1810 | LOCAL lcNewText 1811 | IF xmbIsWindow(This.Parent.hDialog) = 0 1812 | * Possibly the dialog has been closed manually 1813 | This.Parent.hDialog = 0 1814 | This.Interval = 0 && stop the timer 1815 | ELSE 1816 | 1817 | IF NOT This.lStarted && Run the initial setups after creation 1818 | This.Parent.DialogCreated() 1819 | This.lStarted = .T. 1820 | ENDIF 1821 | 1822 | * The dialog is still around, checking timeout 1823 | This.Parent.nXmbTimeout = This.Parent.nXmbTimeout - This.Interval 1824 | 1825 | * Update the header of the dialog if needed 1826 | IF NOT EMPTY(This.Parent.cTimeoutCaption) 1827 | LOCAL lnTimeout 1828 | m.lnTimeout = ROUND(This.Parent.nXmbTimeout / 1000, 0) 1829 | IF m.lnTimeout <> This.nCurrentTimeout 1830 | m.lcNewText = STRTRAN(This.Parent.cHeading, "", "23f1 " + TRANSFORM(m.lnTimeout)) && included the Unicode Watch 1831 | m.lcNewText = TOUNICODE(m.lcNewText) 1832 | * lcNewText = STRTRAN(This.Parent.cHeading, "", TRANSFORM(lnTimeout)) 1833 | * = SetWinText(This.Parent.hDialog, lcNewText) 1834 | =xmbSetWindowTextZ(This.Parent.hDialog, m.lcNewText) 1835 | 1836 | *!* * Changing the captions after the dialog run 1837 | *!* loNewCaption = CREATEOBJECT("PChar", lcNewText) 1838 | *!* =xmbSendMessage(This.Parent.hDialog, TDM_SET_ELEMENT_TEXT, TDE_CONTENT, loNewCaption.GetAddr()) 1839 | ENDIF 1840 | ENDIF 1841 | 1842 | 1843 | IF This.Parent.nDialogType > 1 && Custom control 1844 | 1845 | DO CASE 1846 | CASE This.Parent.nDialogType = 2 && INPUTBOX() 1847 | This.Parent.UpdateText() 1848 | 1849 | CASE INLIST(This.Parent.nDialogType, 3, 4, 5, 6) && DATEBOX() 1850 | This.Parent.UpdateDate() 1851 | 1852 | OTHERWISE 1853 | 1854 | ENDCASE 1855 | 1856 | IF This.Parent._nOriginalTimeout > 0 && We have a timeout active, let it work normally 1857 | ELSE && We reset the timeout, because we need the timer to keep working till the user closes the dialog 1858 | This.Parent.nXmbTimeout = 100000 1859 | ENDIF 1860 | ENDIF 1861 | 1862 | 1863 | IF This.Parent.nXmbTimeout <= 0 1864 | This.Parent.CloseDialog() 1865 | ENDIF 1866 | 1867 | ENDIF 1868 | ENDPROC 1869 | ENDDEFINE 1870 | 1871 | 1872 | ********************************************************************* 1873 | FUNCTION getTextSize 1874 | * Author: Mike Lewis 1875 | * https://www.tek-tips.com/viewthread.cfm?qid=1525491 1876 | * Determines the width in pixels of a given text string, 1877 | * based on a given font, font style and point size. 1878 | 1879 | * Parameters: text string, font name, size in points, 1880 | * font style in format used by FONTMETRIC() 1881 | * (e.g. "B" for bold, "BI" for bold italic; 1882 | * defaults to normal). 1883 | LPARAMETERS tcString, tcFont, tnSize, tcStyle 1884 | LOCAL lnTextWidth, lnAvCharWidth 1885 | IF EMPTY(m.tcStyle) 1886 | m.tcStyle = "" 1887 | ENDIF 1888 | m.lnTextWidth = TXTWIDTH(m.tcString, m.tcFont, m.tnSize, m.tcStyle) 1889 | m.lnAvCharWidth = FONTMETRIC(6, m.tcFont, m.tnSize, m.tcStyle) 1890 | RETURN m.lnTextWidth * m.lnAvCharWidth 1891 | ENDFUNC 1892 | 1893 | 1894 | 1895 | ********************************************************************* 1896 | FUNCTION GetDialogFont(tcFontName, tnFontSize) 1897 | * Code derived from 1898 | * How to find which fonts Windows uses for drawing captions, menus and message boxes 1899 | * https://github.com/VFPX/Win32API/blob/master/samples/sample_556.md 1900 | * by VFPX / Anatolyi Mogylevets 1901 | 1902 | #DEFINE SPI_GETNONCLIENTMETRICS 0x0029 1903 | #DEFINE NONCLIENTMETRICS_SIZE 0x0154 1904 | #DEFINE LOGFONT_SIZE 0x003c 1905 | #DEFINE LOGPIXELSY 0x005a 1906 | 1907 | LOCAL lfHeight, lcBuffer 1908 | DECLARE INTEGER GetLastError IN kernel32 1909 | DECLARE INTEGER GetWindowDC IN user32 INTEGER hWindow 1910 | DECLARE INTEGER SystemParametersInfo IN user32; 1911 | INTEGER uiAction, INTEGER uiParam,; 1912 | STRING @pvParam, INTEGER fWinIni 1913 | DECLARE INTEGER GetDeviceCaps IN gdi32; 1914 | INTEGER hdc, INTEGER nIndex 1915 | DECLARE INTEGER ReleaseDC IN user32; 1916 | INTEGER hWindow, INTEGER hDC 1917 | 1918 | LOCAL lcNonClientMetrics 1919 | * populating NONCLIENTMETRICS structure 1920 | * the size of the structure occupies first 4 bytes 1921 | m.lcNonClientMetrics=BINTOC(NONCLIENTMETRICS_SIZE,"4RS") 1922 | 1923 | * padding the structure to the required size 1924 | m.lcNonClientMetrics=PADR(m.lcNonClientMetrics, NONCLIENTMETRICS_SIZE, CHR(0)) 1925 | 1926 | * retrieving the metrics associated with the nonclient area 1927 | * of nonminimized windows 1928 | IF SystemParametersInfo(SPI_GETNONCLIENTMETRICS,; 1929 | NONCLIENTMETRICS_SIZE, @m.lcNonClientMetrics, 0) = 0 1930 | * ? "SystemParametersInfo call failed:", GetLastError() 1931 | RETURN 1932 | ENDIF 1933 | 1934 | * among other metrics, populated NONCLIENTMETRICS structure 1935 | * contains data for 5 fonts used for drawing: 1936 | * captions, small captions, menus, status bar and message boxes 1937 | m.lcBuffer = SUBSTR(m.lcNonClientMetrics, 281, LOGFONT_SIZE) 1938 | m.tcFontName = STRTRAN(SUBSTR(m.lcBuffer,29,32), CHR(0),"") 1939 | 1940 | LOCAL lhwindow, lhdc, lnPxPerInchY 1941 | m.lhwindow=_screen.HWnd 1942 | m.lhdc=GetWindowDC(m.lhwindow) 1943 | m.lnPxPerInchY = GetDeviceCaps(m.lhdc, LOGPIXELSY) 1944 | =ReleaseDC(m.lhwindow, m.lhdc) 1945 | m.lfHeight=CTOBIN(SUBSTR(m.lcBuffer,1,4),"4RS") 1946 | 1947 | m.tnFontSize = ROUND((ABS(m.lfHeight) * 72) / m.lnPxPerInchY, 0) 1948 | 1949 | RETURN 1950 | 1951 | 1952 | ********************************************************************* 1953 | FUNCTION ToUnicode(tcStr) 1954 | ********************************************************************* 1955 | LOCAL lnUnicodeCnt, lnPos, n, lcReturn, lnPos0, j, lnWidth 1956 | LOCAL laPos[1], lcText, lcUnicode, lnEnd, lnLen, lnStart, lnUnicodeIndex 1957 | m.lnUnicodeCnt = OCCURS("", m.tcStr) 1958 | m.lcReturn = "" 1959 | 1960 | IF m.lnUnicodeCnt = 0 1961 | RETURN STRCONV(m.tcStr + CHR(0), 5) 1962 | ENDIF 1963 | 1964 | DIMENSION m.laPos(m.lnUnicodeCnt,4) 1965 | FOR m.n = 1 TO m.lnUnicodeCnt 1966 | m.lcUnicode = STREXTRACT(m.tcStr, "", "", m.n) 1967 | m.lnStart = AT("", m.tcStr, m.n) 1968 | m.lnEnd = AT("", m.tcStr, m.n) 1969 | m.laPos(m.n,1) = m.lnStart 1970 | m.laPos(m.n,2) = m.lnEnd 1971 | m.laPos(m.n,3) = m.lcUnicode 1972 | m.laPos(m.n,4) = HEXTOUNICODE(m.lcUnicode) 1973 | ENDFOR 1974 | 1975 | m.lnLen = LEN(m.tcStr) 1976 | m.lnUnicodeIndex = 1 1977 | 1978 | FOR m.j = 1 TO m.lnLen 1979 | IF (m.lnUnicodeIndex <= m.lnUnicodeCnt) AND (m.j = m.laPos(m.lnUnicodeIndex,1)) && Get Unicode 1980 | m.lcReturn = m.lcReturn + m.laPos(m.lnUnicodeIndex,4) 1981 | m.j = m.laPos(m.lnUnicodeIndex,2) 1982 | m.lnUnicodeIndex = m.lnUnicodeIndex + 1 1983 | LOOP 1984 | ELSE 1985 | m.lnStart = IIF(m.j = 1, 1, m.laPos(m.lnUnicodeIndex-1,2)+5) 1986 | IF m.lnStart > m.lnLen 1987 | EXIT 1988 | ENDIF 1989 | 1990 | IF m.lnUnicodeIndex > m.lnUnicodeCnt 1991 | m.j = m.lnLen && Finished 1992 | m.lcText = SUBSTR(m.tcStr, m.lnStart) 1993 | ELSE 1994 | m.lnWidth = m.laPos(m.lnUnicodeIndex,1) - m.lnStart 1995 | m.j = m.laPos(m.lnUnicodeIndex,1) - 1 1996 | m.lcText = SUBSTR(m.tcStr, m.lnStart, m.lnWidth) 1997 | ENDIF 1998 | m.lcReturn = m.lcReturn + STRCONV(m.lcText, 5) 1999 | ENDIF 2000 | ENDFOR 2001 | 2002 | RETURN m.lcReturn + CHR(0) 2003 | ENDFUNC 2004 | 2005 | 2006 | ********************************************************************* 2007 | FUNCTION HexToUnicode(tcHex) 2008 | ********************************************************************* 2009 | LOCAL lhHex, lhUnicode, i, lcHex 2010 | lhUnicode = 0h 2011 | FOR i = 1 TO GETWORDCOUNT(tcHex, SPACE(1)) 2012 | lcHex = GETWORDNUM(tcHex, i, SPACE(1)) 2013 | IF LEN(lcHex) = 8 2014 | lhHex = EVALUATE("0h" + SUBSTR(lcHex,3,2) + LEFT(lcHex,2) + SUBSTR(lcHex,7,2) + SUBSTR(lcHex,5,2)) 2015 | ELSE 2016 | lhHex = EVALUATE("0h" + SUBSTR(lcHex,3,2) + LEFT(lcHex,2)) 2017 | ENDIF 2018 | lhUnicode = lhUnicode + lhHex 2019 | ENDFOR 2020 | RETURN lhUnicode 2021 | ENDFUNC 2022 | 2023 | 2024 | 2025 | ********************************************************************* 2026 | FUNCTION xmbLoadImage(hinst, lpszname, utype, cxdesired, cydesired, fuload) 2027 | ********************************************************************* 2028 | DECLARE INTEGER LoadImage IN user32 AS xmbloadimage; 2029 | INTEGER hinst,; 2030 | STRING lpszname,; 2031 | INTEGER utype,; 2032 | INTEGER cxdesired,; 2033 | INTEGER cydesired,; 2034 | INTEGER fuload 2035 | RETURN xmbLoadImage(hinst, lpszname, uType, cxdesired, cydesired, fuload) 2036 | ENDFUNC 2037 | 2038 | 2039 | ********************************************************************* 2040 | FUNCTION FileInDisk(zcFileName) 2041 | ********************************************************************* 2042 | IF TYPE("zcfilename") <> "C" 2043 | RETURN .F. 2044 | ENDIF 2045 | DIMENSION laJunk[1] &&' so it is local 2046 | RETURN (ADIR(laJunk, zcfilename, "ARS") > 0) 2047 | ENDFUNC 2048 | 2049 | 2050 | FUNCTION GetHIcon(tcImgFile) 2051 | LOCAL lhIcon, lcExt, liType 2052 | lhIcon = 0 2053 | IF EMPTY(m.tcImgFile) OR NOT FILE(m.tcImgFile) 2054 | RETURN 0 2055 | ENDIF 2056 | lcExt = UPPER(JUSTEXT(m.tcImgFile)) 2057 | IF lcExt = "ICO" 2058 | liType = IMAGE_ICON 2059 | ELSE 2060 | liType = IMAGE_BITMAP 2061 | ENDIF 2062 | lhIcon = xmbLoadImage(0, FULLPATH(m.tcImgFile), liType, ; 2063 | 0,0, lr_loadfromFile + lr_defaultsize) 2064 | IF lhIcon = 0 2065 | SET STEP ON 2066 | ENDIF 2067 | 2068 | RETURN m.lhIcon 2069 | ENDFUNC -------------------------------------------------------------------------------- /testing/information on displays.SCT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/information on displays.SCT -------------------------------------------------------------------------------- /testing/information on displays.scx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/information on displays.scx -------------------------------------------------------------------------------- /testing/monitor dpi in screen.SCT: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/monitor dpi in screen.SCT -------------------------------------------------------------------------------- /testing/monitor dpi in screen.scx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/monitor dpi in screen.scx -------------------------------------------------------------------------------- /testing/unmanagedforms/thisFolderIntentionallyLeftEmpty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/unmanagedforms/thisFolderIntentionallyLeftEmpty -------------------------------------------------------------------------------- /testing/vfp2c32.fll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/atlopes/DPIAwareManager/e541ef68aabb9c88797690a7d6a222d666c4c785/testing/vfp2c32.fll --------------------------------------------------------------------------------