Cool Excel Magnifying Glass to Zoom the entire Screen !

[Jaafar Tribak]

Hi all,

Here is a Magnifying Glass that you can use in Excel I am not sure about the usefulness of it in the normal day to day use of Excel but it's cool and was challenging to programme. The actual round Glass is actually a simple XL userorm whose standard styles were changed.

Here is a workbook example : http://www.savefile.com/files/1177730

Just point to the round Glass with the mouse and move it around the screen to zoom in. It worked on my machine quite smoothly.

Here is the code that goes in a userform :

Option Explicit

Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Const SRCCOPY = &HCC0020

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private lfrmDC As Long

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    Width As Long
    Height As Long
End Type
'________________________________________________________________________
Private Declare Function CreateEllipticRgn Lib "gdi32" _
                          (ByVal X1 As Long, ByVal Y1 As Long, _
                           ByVal X2 As Long, ByVal Y2 As Long) As Long

 Private Declare Function SetWindowRgn Lib "user32" _
                          (ByVal hWnd As Long, ByVal hRgn As Long, _
                           ByVal bRedraw As Long) As Long
'_________________________________________________________________________
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long


Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Const GWL_STYLE = (-16)
Const WS_SYSMENU = &H80000
Private Const WS_CAPTION As Long = &HC00000

Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
'_________________________________________________________________________

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private lfrmHwnd As Long

'_________________________________________________________________________


Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub ReleaseCapture Lib "user32" ()

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private objCmb As CommandBar



Private Sub UserForm_Initialize()
    Dim lBmp As Long
    Dim IPic As IPicture
    Dim Screen As POINTAPI
    
    'assign the form handle to a module level var
    'will be needed throughout the module
    lfrmHwnd = FindWindow(vbNullString, Me.Caption)
    
    'setup the shape of our form so it looks
    'like a round magnifying glass
    Call FormSetUp(lfrmHwnd)
    
    'get the form dc on which the drawing will be made
    lfrmDC = GetDC(lfrmHwnd)
    
    'get the screen dimensions
    Screen = GetScreenDims
    
    'get a pointer of the screen bitmap
    lBmp = GetScrnBmpHandle(GetDC(0), 0, 0, Screen.Width, Screen.Height)
    
    'create a picture from the bitmap pointer
    Set IPic = GetBitmapPic(lBmp)
    
    'save bitmap to disk
    stdole.SavePicture IPic, (Environ("Temp")) & "\Scr.Bmp"
    'set the form picture to display the bitmap
     Me.Picture = LoadPicture((Environ("Temp")) & "\Scr.Bmp")
    
    'clean up
    Kill (Environ("Temp")) & "\Scr.Bmp"

End Sub


Private Sub UserForm_Activate()

    'the layout event doesn't fire here so refresh form now
    Me.Repaint
   Call UserForm_Layout
   
End Sub


Private Sub UserForm_Layout()

'update the userform background upon moving it
    StretchBlt _
     lfrmDC, 0, 0, Me.Width * 1.5, Me.Height * 1.5, _
     lMemoryDC, Me.Left * 1.5, Me.Top * 1.5, _
     Me.Width, Me.Height, SRCCOPY

End Sub

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

    'show close menu
    If Button = 2 Then objCmb.ShowPopup

End Sub

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

    'move the captionless form with the mouse
     If Button = 1 Then
        Call ReleaseCapture
        SendMessage lfrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    'safety cleanup
    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete

End Sub

'****** Supporting functions **********************************


Private Function GetScrnBmpHandle _
(lScrDC As Long, lScrnLeft As Long, lScrnTop As Long, _
lScrnWidth As Long, lScrnHeight As Long) As Long

    Dim lBmp, lOldBmp As Long
    
    'create a temp memory dc on which to copy the current screen shot
    lMemoryDC = CreateCompatibleDC(lScrDC)
    
    'create a bmp
    lBmp = CreateCompatibleBitmap(lScrDC, lScrnWidth, lScrnHeight)
    
    'select the bmp onto the temp dc
    lOldBmp = SelectObject(lMemoryDC, lBmp)
    DeleteObject lBmp
    
    'copy the screen image onto the temp dc
    BitBlt lMemoryDC, 0, 0, lScrnWidth, lScrnHeight, _
    lScrDC, lScrnLeft, lScrnTop, SRCCOPY
    
    'return our bmp pointer
    GetScrnBmpHandle = lBmp

End Function

Private Function GetBitmapPic(ByVal lBmpHandle As Long) As IPicture

Dim r As Long, IPic As IPicture, IID_IDispatch As GUID, Pic As uPicDesc

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = 1  ' Type of Picture (bitmap)
        .hPic = lBmpHandle ' Handle to bitmap
        .hPal = 0 ' Handle to palette (may be null)
    End With
    'create the pic
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
    Set GetBitmapPic = IPic


End Function


Private Function GetScreenDims() As POINTAPI

    'get screen width an height
    Dim r As POINTAPI
    
    With r
        .Width = GetSystemMetrics(SM_CXSCREEN)
        .Height = GetSystemMetrics(SM_CYSCREEN)
    End With
    GetScreenDims = r

End Function


Private Sub FormSetUp(lhwnd As Long)

    Dim lHr, IStyle As Long
    
    'adjust form dims
    Me.Width = 210
    Me.Height = 195
    
    'Create rightclick close menu
    On Error Resume Next
    CommandBars("GlassPopUp").Delete
    Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
    With objCmb
        objCmb.Name = "GlassPopUp"
        With .Controls.Add(msoControlButton)
            .Caption = "CloseMe"
            .OnAction = "CloseGlass"
        End With
    End With
    On Error GoTo 0
    'set the mouse pointer so it simulates
    'that of a magnifying glass
    
    Me.MousePointer = fmMousePointerCross
    'make the userform captionless and round
    'so it simulates a magnifying glass
    
    IStyle = GetWindowLong(lhwnd, GWL_STYLE)
    IStyle = IStyle And Not WS_CAPTION 'And WS_THICKFRAME
    SetWindowLong lhwnd, GWL_STYLE, IStyle
    DrawMenuBar lhwnd
    lHr = CreateEllipticRgn(0, 0, Me.Width, Me.Height)
    SetWindowRgn lhwnd, lHr, True

End Sub

Copy the code below in a Standard Module :

Option Explicit

Public lMemoryDC As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Sub CloseGlass()

    On Error Resume Next
    DeleteDC lMemoryDC
    CommandBars("GlassPopUp").Delete
    Unload UserForm1

End Sub

Sub Bouton1_QuandClic()

    UserForm1.Show

End Sub

One nice touch that i haven't been able to give the magnifying glass is a frame around it so it can be more visible on the screen. Because of the round shape, framing the userform is quite difficult.

I have tested this on XL2003 Win XP French Version. I am hoping it also works for other XL versions.

Regards.

[Tom Schreiner]

Cool!

[erik.van.geit]

Nice, Jaafar,

If it works on my system, everybody can use it

Welcome with your real name!!

[Krishnakumar]

It's working on XL2000 Win XP.

One drawback I would say that I can't scroll down the sheet while the MG is active.

[RichardSchollar]

That's very cool Jaafar

I like the way it isn't limited to the Excel window too.

Superb work!

Now I wish I could code like that

[Johnny C]

Excellent bit of coding Jaafar

[Jaafar Tribak]

Krushnakumar.

One drawback I would say that I can't scroll down the sheet while the MG is active.

Well, you can always show the Glass userform as modeless and then you can interact with the worksheet while the Glass is on display. However, one limitation is that the Glass will only work for the initial visible screen if you scroll the sheet around. Maybe that is something I should work on together with the outline frame limitation mention above.

Erik.

Welcome with your real name!!

Well. it was time I changed that horrible/weird username I had ( hmm... i am not sure about my real name either )


Thanks everyone for the feedback and i am glad it worked in different XL versions.

Regards.

[Johnny C]

Here's a couple of changes which make it more usable for me; I have screens where I need to see 24months of data at once, with this I can reduce the zoom to 50%. The changes cut the anti-aliasing on the small fonts.

Replace the equivalent lines with

Private Sub UserForm_Layout()

'update the userform background upon moving it
    StretchBlt _
     lfrmDC, 0, 0, Me.Width * 2, Me.Height * 2, _
     lMemoryDC, Me.Left * 2, Me.Top * 2, _
     Me.Width, Me.Height, SRCCOPY

End Sub

this increases the magnification to 2 (which cuts down the antialiasing)

and replace these lines:

Private Sub FormSetUp(lhwnd As Long)

    Dim lHr, IStyle As Long
    
    'adjust form dims
    Me.Width = 410
    Me.Height = 395

which increases the size of the magnifying glass.

Could it be amended to zoom in/out with the mouse scroll wheel Jaafar? I'm not asking you to do it, just curious to see if that's possible

[Jaafar Tribak]

Johnny C.

Yes. what I should have done is place the zoom factor in a Constante so as to make the code easier to edit. I am trying to see if i can improve on this magnifying glass by overcoming the couple of limitations it has. It is actually a good candidate for a Class so things like : ZoomFactor, StartupPos, FrameColor,size ... and other similar Properties could be easily and clearly set without having to edit the code all over the place.

As for the the MouseWheel zoom In/Out( Good idea actually) , i guess it can be done too.

Regards.

[Johnny C]

I'm sure that in an older version of windows - maybe even windows 3.1 - there was a magnifying glass function in the accesibility options. But it didn't work that well with Excel 3, it would crash it quite a lot.