Results 1 to 3 of 3

Thread: [RESOLVED] screen capture mouse position crop

  1. #1

    Thread Starter
    Addicted Member Mojtaba's Avatar
    Join Date
    Dec 2020
    Posts
    130

    Resolved [RESOLVED] screen capture mouse position crop

    Hello friends, I hope you are well
    I want to take a picture from the back of the form at the location of the mouse pointer
    This code works fine and accurately in normal mode SetLayeredWindowAttributes hwnd, 0, 255, 2 , but when I make the form transparent SetLayeredWindowAttributes hwnd, 0, 120, 2 and take a photo, the location of the photo moves and is not accurate.

    HTML Code:
    Option Explicit
    ' Opacity Form
    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
    Private Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    ' End Opacity Form
    
    Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) 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
    ' Mouse Position
    Private Type POINTAPI
    x As Long
    y As Long
    End Type
    Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "User32" (ByVal vKey As Long) As Integer
    Private Declare Function ScreenToClient Lib "User32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    ' End Mouse Position
    
    Private Sub Form_Load()
    Me.ScaleMode = vbPixels
    ' Opacity Form
    Dim Retval As Long
    Retval = GetWindowLong(hwnd, -20)
    Retval = Retval Or 524288
    SetWindowLong hwnd, -20, Retval
    SetLayeredWindowAttributes hwnd, 0, 255, 2
    ' End Opacity Form
    End Sub
    Private Sub Picture1_Click()
    Dim pt As POINTAPI
    GetCursorPos pt
    ScreenToClient hwnd, pt
    Dim wScreen As Long
    Dim hScreen As Long
    Dim hdcScreen As Long
    Dim r As Long
    Picture1.Cls
    wScreen = 50
    hScreen = 50
    Picture1.ScaleMode = vbPixels
    hdcScreen = GetDC(0)
    Me.Visible = False
    r = StretchBlt(Picture1.hdc, pt.x - 25, pt.y - 25, 50, 50, hdcScreen, Text1.Text, Text2.Text, wScreen, hScreen, vbSrcCopy)
    SavePicture Picture1.Image, App.Path & "\ScreenShot.bmp"
    Me.Visible = True
    End Sub
    Private Sub Timer1_Timer()
    Dim pt As POINTAPI
    GetCursorPos pt
    ScreenToClient hwnd, pt
    GetCursorPos pt
    Text1.Text = pt.x
    Text2.Text = pt.y
    End Sub
    Clicking on Picture1 takes a picture
    If you have a better solution or a better code, please help

  2. #2
    Member
    Join Date
    Jul 2020
    Posts
    38

    Re: screen capture mouse position crop

    Hi, Mojtaba.
    In a new project, put a PictureBox and a Timer. Then, copy and paste this code:

    Code:
    Option Explicit
    ' Opacity Form
    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
    Private Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    ' End Opacity Form
    
    Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) 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
    ' Mouse Position
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    
    Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
    ' End Mouse Position
    
    Private Type RECT
        Left   As Long
        Top    As Long
        Right  As Long
        Bottom As Long
    End Type
    
    Private vRect As RECT
    Private vRectPB As RECT
    
    Private vOneClick As Boolean
    
    Private Const CLICK_WIDTH As Single = 50
    Private Const CLICK_HEIGHT As Single = 50
    
    Private Sub Form_Load()
        Me.ScaleMode = vbPixels
        Me.AutoRedraw = True
        Me.BackColor = vbBlack
        
        Picture1.ScaleMode = vbPixels
        Picture1.AutoRedraw = True
        Picture1.Appearance = 0
        Picture1.BorderStyle = 0
        Picture1.Visible = False
        
        Timer1.Interval = 100
        Timer1.Enabled = True
        
        ' Opacity Form
        Dim Retval As Long
        Retval = GetWindowLong(hwnd, -20)
        Retval = Retval Or 524288
        SetWindowLong hwnd, -20, Retval
        SetLayeredWindowAttributes hwnd, 0, 128, 2
        ' End Opacity Form
    End Sub
    
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim pt As POINTAPI
        
        GetCursorPos pt
        
        If Button = 1 Then
            Me.Cls
            
            vOneClick = True
            
            vRect.Left = pt.X
            vRect.Top = pt.Y
            vRect.Right = vRect.Left + CLICK_WIDTH
            vRect.Bottom = vRect.Top + CLICK_HEIGHT
            
            vRectPB.Left = X
            vRectPB.Top = Y
            vRectPB.Right = vRectPB.Left + CLICK_WIDTH
            vRectPB.Bottom = vRectPB.Top + CLICK_HEIGHT
        End If
    End Sub
    
    Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim pt As POINTAPI
        
        If Button = 1 Then
            Me.Cls
            vOneClick = False
            
            GetCursorPos pt
            vRect.Right = pt.X
            vRect.Bottom = pt.Y
            
            vRectPB.Right = X
            vRectPB.Bottom = Y
            Me.Line (vRectPB.Left, vRectPB.Top)-(vRectPB.Right, vRectPB.Bottom), vbRed, B
            Me.Caption = "X=" & pt.X & ", Y=" & pt.Y & " / " & Abs(vRectPB.Right - vRectPB.Left) & "x" & Abs(vRectPB.Bottom - vRectPB.Top)
        End If
    End Sub
    
    Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim vX1 As Single, vY1 As Single
        
        If Button = 1 Then
            If vRect.Left > vRect.Right Then
                vX1 = vRect.Right
                vRect.Right = vRect.Left
                vRect.Left = vX1
            End If
            
            If vRect.Top > vRect.Bottom Then
                vY1 = vRect.Bottom
                vRect.Bottom = vRect.Top
                vRect.Top = vY1
            End If
            
            If vRectPB.Left > vRectPB.Right Then
                vX1 = vRectPB.Right
                vRectPB.Right = vRectPB.Left
                vRectPB.Left = vX1
            End If
            
            If vRectPB.Top > vRectPB.Bottom Then
                vY1 = vRectPB.Bottom
                vRectPB.Bottom = vRectPB.Top
                vRectPB.Top = vY1
            End If
            
            ScreenShot
        End If
    End Sub
    
    Private Sub ScreenShot()
        Dim pt As POINTAPI
        Dim wScreen As Long, hScreen As Long
        Dim hdcScreen As Long
        Dim r As Long
        
        wScreen = vRect.Right - vRect.Left
        hScreen = vRect.Bottom - vRect.Top
        
        Me.Cls
        Picture1.Cls
        Picture1.Width = wScreen
        Picture1.Height = hScreen
        
        Me.Visible = False
        hdcScreen = GetDC(0)
        
        If vOneClick Then
            r = StretchBlt(Picture1.hdc, 0, 0, wScreen, hScreen, hdcScreen, vRect.Left - (wScreen / 2), vRect.Top - (hScreen / 2), wScreen, hScreen, vbSrcCopy)
            Me.PaintPicture Picture1.Image, vRectPB.Left - (wScreen / 2), vRectPB.Top - (hScreen / 2)
        Else
            r = StretchBlt(Picture1.hdc, 0, 0, wScreen, hScreen, hdcScreen, vRect.Left, vRect.Top, wScreen, hScreen, vbSrcCopy)
            Me.PaintPicture Picture1.Image, vRectPB.Left, vRectPB.Top
        End If
        
        SavePicture Picture1.Image, App.Path & "\ScreenShot.bmp"
        Me.Visible = True
    End Sub
    
    Private Sub Timer1_Timer()
        Dim pt As POINTAPI
        
        GetCursorPos pt
        Me.Caption = "X=" & pt.X & ", Y=" & pt.Y & " / " & Abs(vRectPB.Right - vRectPB.Left) & "x" & Abs(vRectPB.Bottom - vRectPB.Top)
    End Sub
    You can select your desired area (click and drag), or use a predefined Width and Height (just click once).

    Name:  GIF 28-11-2023 09-03-14 a. m..gif
Views: 91
Size:  72.7 KB

    See ya!

  3. #3

    Thread Starter
    Addicted Member Mojtaba's Avatar
    Join Date
    Dec 2020
    Posts
    130

    Re: screen capture mouse position crop

    See ya! [/QUOTE]

    Thank you very much Erbin
    It works great

Posting Permissions

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



Click Here to Expand Forum to Full Width