Image quality in userform

[Formula11]

I have a spreadsheet from where I need to refer to about 20 diagrams.
Was going to load each diagram onto a userform, because I need to read cells and diagram at the same time.

The issue with images in forms is that the quality is not great, and difficult to read text in image.

Was looking at the file types when loading an image and there is *.wmf and *.emf available. There are vector image types and quality is the same at any resolution level. The file size goes from 76kb (jpg) to 2650kb (emf). The quality is not improved at all though when emf is loaded to form.

Is there anyway to improve quality so as to read text in image?

 

[Formula11]

Jaafar, is it possible to load picture to Image control in Frame?
I can load it to Form or Frame, but not to Image control.

Private Sub UserForm_Initialize()

     'Works
     FillFormWithImage Form:=Me, imageFilePathName:="C:\test\figure1.PNG"

     'Works
     FillFormWithImage Form:=Me.Frame1, imageFilePathName:="C:\test\figure1.PNG"

     'Doesn't work
     FillFormWithImage Form:=Me.Frame1.Image1, imageFilePathName:="C:\test\figure1.PNG"

End Sub

 

[Jaafar Tribak]

I guess what you are requesting is a functionality similar to google maps where you just mouse scroll over a point on the map and it zooms in\out. .. Also eanbling taping for navigating the map.

I guess it can be done but, it is not going be easy to code in vba. Furtermore, I am not usre how smooth the image update it going to be.

 

[Formula11]

OK thanks Jaafar, I can understand zooming was going to be difficult, so can move past that now.

I think your solution in post #8 is a huge improvement but am still not able to read some pictures with small text, so wanted to incorporate with post #2 from link:
Pan on a zoomed-in image on a userform [SOLVED]

But to do this, would need picture loaded to an Image control, which I'm inferring is not possible then?

 

[Jaafar Tribak]

Jaafar, is it possible to load picture to Image control in Frame?
I can load it to Form or Frame, but not to Image control.

You can't with the the current FillFormWithImage routine because it relies on a HWND which an image control doesn't have. The code\routine will have to be updated to accomodate controls such as image controls ... I will post an update later on.

 

[Formula11]

OK thanks for confirming

 

[Jaafar Tribak]

Jaafar, is it possible to load picture to Image control in Frame?
I can load it to Form or Frame, but not to Image control.

Try this more generic routine whitch should work with the UserForm or Frame containers as well as with any control that supports the Picture Property:

In the UserForm Module:

Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef hwnd As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#End If


Private Sub UserForm_Initialize()
    ' Load image into Frame1.Image1 control
     FillObjectWithImage Obj:=Me.Frame1.Image1, imageFilePathName:="C:\test\figure1.PNG"  '<== change PathName + extension to suit.
End Sub


Private Sub FillObjectWithImage(ByVal Obj As Object, ByVal imageFilePathName As String)

    Dim oWIA As Object, oImg As Object
    Dim nPixelWidth As Long, nPixelHeight As Long
    Dim sngWidth As Single, sngHeight As Single
    Dim hwnd As Long
  
    On Error GoTo QR
  
        Call CallByName(Obj, "Picture", VbSet, Nothing)
      
        If Err = 0& Then
      
            Call IUnknown_GetWindow(Obj, hwnd)
          
            With Obj
                If hwnd Then
                    sngWidth = .InsideWidth:  sngHeight = .InsideHeight
                Else
                    sngWidth = .Width:        sngHeight = .Height
                End If
                nPixelWidth = PTtoPX(sngWidth, False)
                nPixelHeight = PTtoPX(sngHeight, True)
            End With
      
            Set oWIA = CreateObject("WIA.ImageProcess")
            Set oImg = CreateObject("WIA.ImageFile")
            oImg.LoadFile imageFilePathName
      
            With oWIA
                .Filters.Add .FilterInfos.Item("Scale").FilterID
                .Filters(1).Properties("MaximumWidth") = nPixelWidth
                .Filters(1).Properties("MaximumHeight") = nPixelHeight
                .Filters(1).Properties("PreserveAspectRatio") = False
                Set Obj.Picture = .Apply(oImg).FileData.Picture
            End With
      
        End If
  
    On Error GoTo 0

    Exit Sub
  
QR:
  
    MsgBox "Error!" & vbNewLine & vbNewLine & _
    "Invalid file PathName or Object doesn't support the Picture Property."

End Sub

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    #If Win64 Then
        Const NULL_PTR = 0^
    #Else
        Const NULL_PTR = 0&
    #End If
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

 

[Formula11]

Thanks again Jaafar, this works as expected
Cheers

 

[patricktoulon1]

Hello just in passing I came across your discussion

you can simplify your code
below two generic functions using a single API
you have your DPI and the points to pixel coefficient
i'me declared then api in vba7 and vba6 (works in all excel version

this is an exemple

'patricktoulon
#If VBA7 Then
    Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
#Else
    Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As Long) As Long
#End If

Function ScreenDPI() As Long: ScreenDPI = GetDpiForWindow(Application.hWnd): End Function

Function PTtoPX(Optional points# = 0) As Double
    'patricktoulon(france)
    If points = 0 Then points = 1
    PTtoPX = points * ((1 / (ScreenDPI / 72)))
End Function

'exemples of test
Sub test()
    MsgBox "the Dpi initited for your screen is " & ScreenDPI
    MsgBox " the coefficient poits to pixel  in your application system is " & PTtoPX
    MsgBox "40 points = " & PTtoPX(40) & " pixels"
End Sub

enjoy'
Patrick

 

[Jaafar Tribak]

you can simplify your code
below two generic functions using a single API
you have your DPI and the points to pixel coefficient
i'me declared then api in vba7 and vba6 (works in all excel version

Nice. I never used that function. Apparently, it is available in Window 8 and later ... Not only is it shorter but it is also DPI aware.
Thanks.

 

[Jaafar Tribak]

This got me interested to see if we can use the mousewheel to zoom in\out an image loaded in an image control ... Also to pan the image.

The image is is contained inside a Frame control.

It is a bit slow but, it is the closest I could get.

Workbook Example:
ZoomAndPanImage.xlsm

Preview:
https://s3.gifyu.com/images/bSoyD.gif"

Code in the UserForm Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal X As Long, ByVal Y As Long, ppacc As Any, pvarChild As Variant) As Long
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal Hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32.dll" (ByVal Hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal Hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal Hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal X As Long, ByVal Y As Long, ppacc As Any, pvarChild As Variant) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, hUF As LongPtr) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal Hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetClientRect Lib "user32.dll" (ByVal Hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function GetDC Lib "user32" (ByVal Hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type Msg
    Hwnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private oWIA As Object, oImg As Object, oImagesStack As Object
Private nMaxWidth As Long, nMaxHeight As Long
Private sngOldX As Single, sngOldY As Single
Private sngZoomPointX As Single, sngZoomPointY As Single
Private bLooping  As Boolean, bPanning As Boolean

Private Const IMAGE_PATH_NAME = "C:\Users\hp\Downloads\math.png" ' <== change as required.

    
Private Sub UserForm_Initialize()

    Dim Hwnd As LongPtr, hFrame As LongPtr
    
    Set oImagesStack = CreateObject("Scripting.Dictionary")
    
    Call IUnknown_GetWindow(Me, Hwnd)
    hFrame = Frame1.[_GethWnd]
    
    With Image1
        .Left = 0
        .Top = 0
        .Width = Frame1.Width
        .Height = Frame1.Height
    End With
    
    LoadWIAImage Image1, hFrame, IMAGE_PATH_NAME
    
End Sub

Private Sub UserForm_Activate()
    Call MonitorMouseWheel
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    bLooping = False
    ' CleanUp
    Set oWIA = Nothing
    Set oImg = Nothing
    Set oImagesStack = Nothing
End Sub

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        bPanning = True
        sngOldX = X
        sngOldY = Y
    End If
End Sub

Private Sub image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    bPanning = False
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Dim sngCurLeft As Single, sngCurTop As Single
    
    If Button = 1 And bPanning Then
        With Image1
            sngCurLeft = .Left + (X - sngOldX)
            sngCurTop = .Top + (Y - sngOldY)
            If (sngCurLeft < 0 And sngCurLeft > Frame1.InsideWidth - .Width) And _
               (sngCurTop < 0 And sngCurTop > Frame1.InsideHeight - .Height) Then
                .Left = .Left - sngOldX + X
                .Top = .Top - sngOldY + Y
            End If
        End With
    End If

End Sub

Private Sub ZoomIn()

    Const sngZoomFactor = 2&
    Dim OldWidth As Single, oldHeight As Single
    
    With Image1
    
        oImagesStack.Add .Picture, .Left & "|" & .Top & "|" & .Width & "|" & .Height
        OldWidth = .Width
        oldHeight = .Height
        .Width = .Width * sngZoomFactor
        .Height = .Height * sngZoomFactor
        
        With oWIA.Filters(1)
            .Properties("MaximumWidth") = nMaxWidth * sngZoomFactor
            .Properties("MaximumHeight") = nMaxHeight * sngZoomFactor
            .Properties("PreserveAspectRatio") = False
            Set Image1.Picture = oWIA.Apply(oImg).FileData.Picture
        End With
        
        .Left = .Left - sngZoomPointX
        .Top = .Top - sngZoomPointY
        
        nMaxWidth = PTtoPX(.Width, False)
        nMaxHeight = PTtoPX(.Height, True)
    
    End With

End Sub

Private Sub ZoomOut()

    Dim sImgDimensions As String

    If oImagesStack.Count Then
        With Image1
            sImgDimensions = oImagesStack.Items()(oImagesStack.Count - 1&)
            Set .Picture = oImagesStack.Keys()(oImagesStack.Count - 1&)
            .Left = Split(sImgDimensions, "|")(0&)
            .Top = Split(sImgDimensions, "|")(1&)
            .Width = Split(sImgDimensions, "|")(2&)
            .Height = Split(sImgDimensions, "|")(3&)
            nMaxWidth = PTtoPX(.Width, False)
            nMaxHeight = PTtoPX(.Height, True)
        End With
        oImagesStack.Remove oImagesStack.Keys()(oImagesStack.Count - 1&)
    End If

End Sub

Private Sub LoadWIAImage(ByVal img As Image, ByVal hImgContainer As LongPtr, ByVal imageFilePathName As String)

    Dim uRect As RECT
      
    Call GetClientRect(hImgContainer, uRect)

    With uRect
        nMaxWidth = .Right - .Left
        nMaxHeight = .Bottom - .Top
    End With
    
    Set oWIA = CreateObject("WIA.ImageProcess")
    Set oImg = CreateObject("WIA.ImageFile")
    oImg.LoadFile imageFilePathName

        oWIA.Filters.Add oWIA.FilterInfos.Item("Scale").FilterID
         With oWIA.Filters(1)
        .Properties("MaximumWidth") = nMaxWidth
        .Properties("MaximumHeight") = nMaxHeight
        .Properties("PreserveAspectRatio") = False
        Set img.Picture = oWIA.Apply(oImg).FileData.Picture
    End With

End Sub

Private Sub MonitorMouseWheel()

    Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg
    Dim lDelta As Integer, lAccumulatedDelta  As Long
    Dim X As Long, Y As Long
    Dim oiAcc As IAccessible
    Dim nLeft As Long, nTop As Long
 
    Do
        bLooping = True
            
        Call WaitMessage
        If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
        
         X = tMsg.pt.X: Y = tMsg.pt.Y
        
         #If Win64 Then
               Dim lPt As LongLong
               Call CopyMemory(lPt, tMsg.pt, LenB(lPt))
               Call AccessibleObjectFromPoint(lPt, oiAcc, 0&)
           #Else
               Call AccessibleObjectFromPoint(X, Y, oiAcc, 0&)
           #End If
          
           Call oiAcc.accLocation(nLeft, nTop, 0&, 0&)
        
           lDelta = HiWord(tMsg.wParam)
           If lDelta * lAccumulatedDelta > 0& Then
               lAccumulatedDelta = lAccumulatedDelta + lDelta
           Else
               lAccumulatedDelta = lDelta
           End If
        
           If oiAcc.accRole(0&) = 40& Then
               If lAccumulatedDelta > 0& Then
                   sngZoomPointX = PXtoPT(X - nLeft, False)
                   sngZoomPointY = PXtoPT(Y - nTop, True)
                   Call ZoomIn
               Else
                   sngZoomPointX = PXtoPT(nLeft - X, False)
                   sngZoomPointY = PXtoPT(nTop - Y, True)
                   Call ZoomOut
               End If
           End If
        
        End If  'End of PeekMessage

       DoEvents
        
    Loop Until bLooping = False

End Sub

Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72&
    PXtoPT = (Pixels * POINTSPERINCH) / ScreenDPI(bVert)
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

Private Function HiWord(Param As LongPtr) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function