Using Excel/VBA I have made an Excel userform containing only an InkPicture control. I have managed to load a picture (Stretch mode), make the form resizable (API calls), resize the inkpicture upon resize. This is all working perfectly well.
I also need to resize the Ink manually, as it does not scale with the InkPicture. This should also be easily implemented with InkPicture1.Renderer.ScaleTransform and it works perfectly well - most of the time!
Problem: When resizing the userform the ScaleTransform function will stop scaling in either horizontal or vertical direction - but only at specific Windows Display Scales: 125%, 175%, 200% and 225% - whereas scaling 100%, 150% and 250% works perfectly.
The change of behavior at different Windows Display Scales is weird and I have looked for driver updates and performance bottlenecks.
I am uncertain if Display Scale only applies to touchscreens.
The have the same problem on both my computers: - Microsoft Surface Pro 6 (i5), Windows 10, Office 365 - Excel 32bit - Lenovo Yoga (i7), Windows 10, Office 365 - Excel 64bit. Both are touchscreens, using onboard Intel Graphics. Running on external monitors makes no change.
I have investigated: - Windows, Office and all Drivers should be up to date - Disabling hardware acceleration (not applicable on my computers) - Alternative code: using inkpicture.resize event instead - Alternative code: ScaleTransforming one direction at a time
To reproduce the error you need to... - Create a macro enabled workbook - Create UserForm (UserForm1) - Add the InkPicture ActiveX control to the project - Insert an InkPicture control (InkPicture1) - Copy VBA code below into the project
Paste into module and run as macro:
Public Sub OpenUserForm1()
UserForm1.Show
End Sub
Paste into userform1 code:
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Dim widthBefore As Double
Dim heightBefore As Double
Private Sub UserForm_Initialize()
Me.InkPicture1.Top = 0
Me.InkPicture1.Left = 0
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
Call DrawForm
End Sub
Private Sub UserForm_Activate()
Call MakeFormMaximizable
End Sub
Private Sub UserForm_Resize()
Call DrawForm
End Sub
Private Sub DrawForm()
If Me.InsideHeight = 0 Or Me.InsideWidth = 0 Then Exit Sub
Me.InkPicture1.Width = Me.InsideWidth
Me.InkPicture1.Height = Me.InsideHeight
Dim hMultiplier As Single, vMultiplier As Single
hMultiplier = Me.InkPicture1.Width / widthBefore
vMultiplier = Me.InkPicture1.Height / heightBefore
' This function messes up!
Me.InkPicture1.Renderer.ScaleTransform hMultiplier, vMultiplier
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
End Sub
Private Sub MakeFormMaximizable()
Dim BitMask As LongPtr
Dim Window_Handle As LongPtr
Dim WindowStyle As LongPtr
Dim Ret As LongPtr
Const GWL_STYLE As Long = -16
Const WS_THICKFRAME As Long = &H40000
Const MAX_BOX As Long = &H10000
Box_Type = MAX_BOX
Window_Handle = GetForegroundWindow()
WindowStyle = GetWindowLongPtr(Window_Handle, GWL_STYLE)
BitMask = WindowStyle Or Box_Type Or WS_THICKFRAME
Ret = SetWindowLongPtr(Window_Handle, GWL_STYLE, BitMask)
Ret = DrawMenuBar(Window_Handle)
End Sub
To get Wanted/Expected behavior: - Set Graphic Display Scale to 100% (followed by logout/login) - Open Excel workbook / Open Userform - Draw ink on userform - Resizing the userform will be completely smooth and seamless - perfect!
To get Weird behavior: - Set Graphic Display Scale to 200% (followed by logout/login) - Open Excel workbook / Open Userform - Draw ink on userform - When resizing the userform the drawn ink no longer follows. It either only scales in one direction, or scales in a direction that is not being scaled.
I hope someone can reproduce the same error/behavior, has had similar experience, has an idea or ideally a fix.
Thanks a lot.
I found a work around. You need to ignore the calculations the InkPicture Control makes on its Rendering Transform Matrix and instead use the Inkpicture.SetViewTransform and the InkTransform.SetTranform functions manually. The code is quite clear and now it will make your UserForm, InkPicture and your Ink resize coordinated and smoothly across all display settings (those tested anyways).
However, the scale factor will not be consistent across display settings - you need to calibrate the coordinate systems! I have done this by creating an initial scaling factor with the function Inkpicture.GetViewTransform. This needs to be called from Form_Init and I have wrapped the code in function GetInitScale in the code below.
Here is the full modified code except UserForm1.show:
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "Gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Const TWIPSPERINCH = 1440
Dim widthBefore As Double, heightBefore As Double
Dim xInitScale As Double, yInitScale As Double
Private Sub UserForm_Initialize()
widthBefore = Me.InkPicture1.Width
heightBefore = Me.InkPicture1.Height
Me.InkPicture1.Top = 0
Me.InkPicture1.Left = 0
Call GetInitScale
Call DrawForm
End Sub
Private Sub UserForm_Activate()
Call MakeFormMaximizable
End Sub
Private Sub UserForm_Resize()
Call DrawForm
End Sub
Private Sub DrawForm()
Me.InkPicture1.Width = Me.InsideWidth
Me.InkPicture1.Height = Me.InsideHeight
Call ScaleInk
End Sub
Private Sub GetInitScale()
Dim aTransform As New InkTransform
Dim eM11 As Single, eM12 As Single, eM21 As Single, eM22 As Single, eDx As Single, eDy As Single
' Remember initial transform to ensure robustness for diffrent display settings
Me.InkPicture1.Renderer.GetViewTransform aTransform
aTransform.GetTransform eM11, eM12, eM21, eM22, eDx, eDy
xInitScale = eM11
yInitScale = eM22
End Sub
Private Sub ScaleInk()
Dim aTransform As New InkTransform
Dim eM11 As Single, eM22 As Single
' Set transformation matrix manually
eM11 = xInitScale * Me.InkPicture1.Width / widthBefore
eM22 = yInitScale * Me.InkPicture1.Height / heightBefore
' Set new Transform
aTransform.SetTransform eM11, 0, 0, eM22, 0, 0
Me.InkPicture1.Renderer.SetViewTransform aTransform
End Sub
Private Sub MakeFormMaximizable()
Dim BitMask As LongPtr
Dim Window_Handle As LongPtr
Dim WindowStyle As LongPtr
Dim Ret As LongPtr
Const GWL_STYLE As Long = -16
Const WS_THICKFRAME As Long = &H40000
Const MAX_BOX As Long = &H10000
Box_Type = MAX_BOX
Window_Handle = GetForegroundWindow()
WindowStyle = GetWindowLongPtr(Window_Handle, GWL_STYLE)
BitMask = WindowStyle Or Box_Type Or WS_THICKFRAME
Ret = SetWindowLongPtr(Window_Handle, GWL_STYLE, BitMask)
Ret = DrawMenuBar(Window_Handle)
End Sub
Hope this becomes useful to someone. It certainly was to me :-)
/Cheers