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 : https://www.box.com/shared/c1ujurjhkt

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.

 

[huntersh]

How would I modify this code to make a bitmap of another application's window (internet explorer for example) instead of the desktop?

 

[huntersh]

Maybe if its better if I clarify what I'm trying to accomplish.......

So I have modified the posted code as follows and I have been successful at changing the code to make a bitmap of only Excel. But how do I change the code to make a bitmap of another window? I have tried using another window's caption but this doesn't seem to work.

Sub StorePicture()
    
    Dim lBmp As Long
    Dim IPic As IPicture
    Dim Screen As POINTAPI
    Dim ThisWindow As Long
        
    'get the screen dimensions
    Screen = GetScreenDims
    
    ThisWindow = FindWindow(vbNullString, Application.Caption)
    
    'get a pointer of the screen bitmap
    lBmp = GetScrnBmpHandle(GetDC(ThisWindow), 0, 0, Screen.Width / 3, Screen.Height / 3)
    
    'create a picture from the bitmap pointer
    Set IPic = GetBitmapPic(lBmp)
    
    'save bitmap to disk
    stdole.SavePicture IPic, ThisWorkbook.Path & "\Scr.Bmp"
    
'    Sheet1.Image1.Picture = LoadPicture( _
'            "C:\Documents and Settings\hinshahun\My Documents\Scr.BMP")
    ActiveSheet.Shapes("Rectangle 5").Fill.UserPicture _
        ThisWorkbook.Path & "\Scr.Bmp"
    
    Kill ThisWorkbook.Path & "\Scr.Bmp"
    
End Sub

 

[wilcowoods]

Jafaar - very nice work.

 

[Jaafar Tribak]

Just posting a fresh demo workbook as the above link is no longer working.

ExcelMagnifier

 

[HarryS]

Thanks for the great Functions.. With a movable adjustable, autoshape rectangle to pick a screen region,, some points to pixels conversion (to cope with changing window positions and sizes and excel versions . very useful for brushes pixels etc) , some WIA file compress convert... you can pick any rectangle of the screen and save it as BMP and or JPG... A cross of the Snip program and the magnifing glass. Contact me with email addres if you want the code that I addaped from this excellent work by Jafaar .. and many other ideas from this board

 

[Emma X]

Hi Jaafar,
I am urrently working with Excel 2007. My problem now is that I want to zoom in one whole worksheet so that everything there will be in one screen without any scrolling down or up. Can you help me with this little bit?

If I only use zoom in in the toolbar, the whole worksheet will not fit in one screen any more. I need to scroll down. Is it possible that I do it with macro? Thanks so much!

BR
--Emma X

 

[Greg Truby]

Emma,

Am I understanding you correctly? You are trying to drop the zoom below 10%? What is it that you are hoping to accomplish by shrinking the worksheet to such an extent? In any event, I do not think that Jafaar's solution here would be able to do anything. It can take a portion of the screen and enlarge it, but I do not think that it could take an image that is not being projected on the screen and shrink it.

Assuming I have understood you correctly the only solution that I can even dream up would be to somehow fool Excel into thinking you had a much bigger monitor that you actually have and then capture a screen image from the larger virtual (non-existant) monitor and resize it to your actual monitor.

But that brings me back to my original question - what are you trying to accomplish? Even at a 10% nothing is legible, you can only see the "shape" of the worksheet so to speak. At sub-10% that would only be even more true.

 

[Andrew Poulsom]

Did you try selecting the cells that you want to fill the screen and clicking 'Zoom to Selection'?

 

[Greg Truby]

Did you try selecting the cells that you want to fill the screen and clicking 'Zoom to Selection'?

Andrew, if she's zooming as small as possible and it's still not all fitting, using Zoom to Selection will still not drop zoom below 10%. (Of course I may be misunderstanding her post.)

 

[Jaafar Tribak]

The Magnifying glass is based on a Modal UserForm that's why you can't scroll the worksheet while the Magnifying glass is being displayed.... This is a limitation and were it not for this limitation you woudn't be needing to zoom the worksheet.

If I find a workaround this problem I"ll post it here.