Page 1 of 6 123 ... LastLast
Results 1 to 10 of 55

Thread: Cool Excel Magnifying Glass to Zoom the entire Screen !

  1. #1
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,395
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default Cool Excel Magnifying Glass to Zoom the entire Screen !

    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 :

    Code:
    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 :

    Code:
    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.
    Last edited by xenou; Mar 24th, 2013 at 06:29 PM. Reason: Update Link
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  2. #2
    Board Regular
    Join Date
    Mar 2002
    Location
    Cincinnati, Ohio, USA
    Posts
    6,867
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default

    Cool!

  3. #3
    MrExcel MVP erik.van.geit's Avatar
    Join Date
    Feb 2003
    Location
    Belgium 3272 Testelt
    Posts
    17,832
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    Nice, Jaafar,

    If it works on my system, everybody can use it

    Welcome with your real name!!
    I love Jesus

    email Erik

    founder of DRAFT

    my free Addins
    Table-It download & info
    Formula Translator 04

  4. #4

    Join Date
    Feb 2003
    Location
    Gurgaon/Thrissur
    Posts
    2,615
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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.

  5. #5
    MrExcel MVP Richard Schollar's Avatar
    Join Date
    Apr 2005
    Location
    UK
    Posts
    23,707
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default

    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

    Richard Schollar

    Using xl2013

  6. #6
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    996
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default

    Excellent bit of coding Jaafar
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

  7. #7
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,395
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default

    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.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  8. #8
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    996
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

    Code:
    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:

    Code:
    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
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

  9. #9
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,395
    Post Thanks / Like
    Mentioned
    40 Post(s)
    Tagged
    3 Thread(s)

    Default

    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.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  10. #10
    Board Regular Johnny C's Avatar
    Join Date
    Nov 2006
    Location
    Liverpool, UK
    Posts
    996
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    0 Thread(s)

    Default

    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.
    "If you think this Universe is bad, you should see some of the others" - Philip K. DiĘk

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •