[RESOLVED] Magnifying form

I remember in a windows utitity that Magnify's an area
Is there any way to make my form sortof like a Magnifying glass?

Thanks

Check out this thread and see if it helps
http://www.vbforums.com/showthread.p...54#post2189954

If you need help adapting it to your needs let me kknow.

Yea sortof but can I have it magnify windows not my form?

Yes easily,

Just use the screen's hdc in place of the big picturebox hdc and your form's hdc in place of the little ones.

Ok a little complicated please example :o

Sorry for my stupidity :o
Did it thanks!

can you please post your code that worked?

Sure

If you downloaded his project replace the Image1_MouseMove with this

VB Code:

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
    If Button = vbLeftButton Then
        Image1.Left = Image1.Left - XX + Me.ScaleX(X, vbTwips, vbPixels)
        Image1.Top = Image1.Top - YY + Me.ScaleY(Y, vbTwips, vbPixels)
        StretchBlt Picture3.hdc, 0, 0, Picture3.Width, Picture3.Height, Me.hdc, Image1.Left, Image1.Top, Image1.Width, Image1.Height, vbSrcCopy
    End If
 
End Sub

His code does not work well with transparent forms or opaque forms

I finally got a chance to play around with this a bit. The problem with magnifying on the same form you're moving around is that you have to keep hiding the form so that you can see what is behind it. Maybe there is someway to tap into the buffer used to repaint the background and get your data from there. Anyway here is what I have that works pretty well.

VB Code:

Option Explicit
 
Private srcDc As Long
 
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 GetDC Lib "user32" ( _
    ByVal hwnd As Long _
) As Long
 
Private Declare Function GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, _
    lpRect As RECT _
) As Long
 
Private Declare Function GetClientRect Lib "user32" ( _
    ByVal hwnd As Long, _
    lpRect As RECT _
) As Long
 
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
Private Sub Form_Load()
    Me.ScaleMode = vbPixels
    srcDc = GetDC(0&)
    Set FormSubClass = New clsSubClass
    FormSubClass.Enable Me.hwnd
End Sub
 
Sub ZoomIn(ZoomFactor As Long)
 Dim xWidth As Long, yHeight As Long
 Dim xLeft As Long, ytop As Long
 Dim nSrcWidth As Long, nSrcHeight As Long
 
 Dim xBorder As Long
 Dim yBorder As Long
 Dim wndRect As RECT
 Dim clientRect As RECT
 
 GetWindowRect Me.hwnd, wndRect
 GetClientRect Me.hwnd, clientRect
 
 'need to hide form so we can see what is behind it
  Me.Visible = False
  DoEvents
 
'get size and location of form
 xBorder = Int((wndRect.Right - wndRect.Left - clientRect.Right) / 2)
 yBorder = wndRect.Bottom - wndRect.Top - clientRect.Bottom - xBorder
 
 xWidth = clientRect.Right
 yHeight = clientRect.Bottom
 nSrcWidth = Int(xWidth / ZoomFactor)
 nSrcHeight = Int(yHeight / ZoomFactor)
 xLeft = wndRect.Left + xBorder
 ytop = wndRect.Top + yBorder
 
'make the magnified picture
 StretchBlt Me.hdc, 0, 0, xWidth, yHeight, srcDc, xLeft, ytop, nSrcWidth, nSrcHeight, vbSrcCopy
 Me.Visible = True
 
End Sub

Now, when do you call the ZoomIn routine? You can subclass the form and call it whenever the form is moved

VB Code:

Private Sub FormSubClass_WMArrival(hwnd As Long, uMsg As Long, _
    wParam As Long, lParam As Long, lRetVal As Long)
    Select Case uMsg
    Case WM_MOVE
        ZoomIn 2
    End Select
End Sub

This causes a lot of flashing, so maybe you just want to call it once the form has completed moving

Here is a much better solution.
create a memory device context to hold the screen picture
update that DC only when you start to move the form
while the form is being moved, copy a region of that DC onto the form
It works more smoothly if the borders of the form are removed or set to fixed single.

VB Code:

Option Explicit
 
Private hdcScreen As Long
Private hdcCompatible As Long
Private hbmScreen As Long
 
Private ScreenWidth As Long
Private screenHeight As Long
Private XX As Single
Private YY As Single
 
Private ScaleFactor As Long
 
 
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 GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, _
    lpRect As RECT _
) As Long
 
Private Declare Function GetClientRect Lib "user32" ( _
    ByVal hwnd As Long, _
    lpRect As RECT _
) As Long
 
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
 
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
    ByVal hdc 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 Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hdc As Long _
) As Long
 
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" ( _
    ByVal lpDriverName As String, _
    ByVal lpDeviceName As String, _
    ByVal lpOutput As String, _
    ByVal lpInitData 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 GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal nIndex 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 Const HORZRES = 8            '  Horizontal width in pixels
Private Const VERTRES = 10           '  Vertical width in pixels
 
Sub UpDateImage()
    Me.Visible = False
    DoEvents
         'Copy color data for the entire display into a
         'bitmap that is selected into a compatible DC.
 
        If BitBlt(hdcCompatible, _
               0, 0, _
               ScreenWidth, screenHeight, _
               hdcScreen, _
               0, 0, _
               vbSrcCopy) = 0 Then
 
                MsgBox "Screen to Compat Blt Failed"
            Exit Sub
        End If
    Me.Visible = True
    DoEvents
End Sub
 
Sub ZoomIn(ZoomFactor As Long)
 Dim xLeft As Long, ytop As Long
 Dim nSrcWidth As Long, nSrcHeight As Long
 Dim ScaleFactor As Single
 Dim xBorder As Long
 Dim yBorder As Long
 Dim wndRect As RECT
 Dim clientRect As RECT
 
 GetWindowRect Me.hwnd, wndRect
 GetClientRect Me.hwnd, clientRect
 
'get size and location of form
 xBorder = Round((wndRect.Right - wndRect.Left - clientRect.Right) / 2, 0)
 yBorder = wndRect.Bottom - wndRect.Top - clientRect.Bottom - xBorder
 
 nSrcWidth = Round(clientRect.Right / ZoomFactor, 0)
 nSrcHeight = Round(clientRect.Bottom / ZoomFactor, 0)
 
 'align the center of windows
 ScaleFactor = (ZoomFactor - 1) / (2 * ZoomFactor)
 xLeft = wndRect.Left + xBorder + Round(clientRect.Right * ScaleFactor, 0)
 ytop = wndRect.Top + yBorder + Round(clientRect.Bottom * ScaleFactor, 0)
 
'make the magnified picture
 
 StretchBlt Me.hdc, 0, 0, clientRect.Right, clientRect.Bottom, hdcCompatible, xLeft, ytop, nSrcWidth, nSrcHeight, vbSrcCopy
 Me.Refresh
 
End Sub
 
Private Sub Form_Load()
 
    Me.AutoRedraw = True
    ScaleFactor = 2
    
' Create a normal DC and a memory DC for the entire screen. The
' normal DC provides a "snapshot" of the screen contents. The
' memory DC keeps a copy of this "snapshot" in the associated
' bitmap.
 
hdcScreen = CreateDC("DISPLAY", vbNullString, vbNullString, 0&)
If hdcScreen = 0 Then
    MsgBox "CreateDC failed"
    Exit Sub
End If
 
 
hdcCompatible = CreateCompatibleDC(hdcScreen)
If hdcCompatible = 0 Then
    MsgBox "hdcCompatible failed"
    Exit Sub
End If
 
ScreenWidth = GetDeviceCaps(hdcScreen, HORZRES)
screenHeight = GetDeviceCaps(hdcScreen, VERTRES)
 
' Create a compatible bitmap for hdcScreen.
hbmScreen = CreateCompatibleBitmap(hdcScreen, _
                     ScreenWidth, _
                     screenHeight)
 
If (hbmScreen = 0) Then
    MsgBox "hbmScreen failed"
    Exit Sub
End If
 
' Select the bitmaps into the compatible DC.
If SelectObject(hdcCompatible, hbmScreen) = 0 Then
    MsgBox "Compatible Bitmap Selection Failed!"
    Exit Sub
End If
 
    UpDateImage
    ZoomIn ScaleFactor
    
 
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Select Case Button
    Case vbLeftButton
        XX = X 'Me.ScaleX(X, vbTwips, vbPixels)
        YY = Y 'Me.ScaleY(Y, vbTwips, vbPixels)
        UpDateImage
    Case vbRightButton
        PopupMenu mnPopup
    End Select
    
End Sub
 
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim NewLeft As Integer
Dim NewTop As Integer
    If Button = vbLeftButton Then
        NewLeft = Me.Left - XX + X
        NewTop = Me.Top - YY + Y
        If NewLeft + Me.Width <= Screen.Width Then
            If NewLeft >= 0 Then
                Me.Left = NewLeft
            Else
                Me.Left = 0
            End If
        Else
            Me.Left = Screen.Width - Me.Width
        End If
 
        If NewTop + Me.Height <= Screen.Height Then
            If NewTop >= 0 Then
                Me.Top = NewTop
            Else
                Me.Top = 0
            End If
        Else
            Me.Top = Screen.Height - Me.Height
        End If
 
    ZoomIn ScaleFactor
  End If
 
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    DeleteObject hbmScreen
    DeleteDC hdcScreen
    DeleteDC hdcCompatible
End Sub
 
Private Sub mnExit_Click()
    Unload Me
End Sub
 
Private Sub mnFactor_Click(Index As Integer)
    ScaleFactor = Index
    ZoomIn ScaleFactor
End Sub

mouer, the stuff you come up with always amazes me, great job.

Awe shucks... :blush:

Thats AwsomE! :thumb:
Great help
thanks much!

Hi, this is VERY useful !
2 questions =>
1) how can I make it work on a second screen, used as extended desktop, so far it works only on the main screen
2) will it still work in Windows 7 ?

This thread is 7 years old. These guys probably don't post anymore.