[VBA] Resize a screenshot on specific coordinates

[Eawyne]

Hiyall,

I'm trying to automate a screenshot button that resizes the image and then cuts it so it can be pasted into a mail. Here's the code I have that does just that (taking the snap, pasting it in Excel, do stuff on the shape and then cutting it - see uploaded image) :

Sub CopyScreen()

    Application.SendKeys "({1068})", True
    DoEvents
    ActiveSheet.Paste
    
    Dim shp As Shape
    With ActiveSheet
        Set shp = .Shapes(.Shapes.Count)
    End With
    
    Dim h As Single, w As Single
    'h = -(600 - shp.Height)
    'w = -(800 - shp.Width)
    
    shp.LockAspectRatio = False
    shp.PictureFormat.CropRight = w
    shp.PictureFormat.CropBottom = h
    'shp.Cut

End Sub

But the problem is that the size is a bit too large for a mail, and setting up heigh and weight do so on an absolute manner, from top and left ; I would like to make it crop around the center of the image (as regardless of the screen, the Form always shows up in the middle of it). Is there a way to do this ?

I'm trying to automate this process, as people tend not to do the required screenshot for those important mails. As it appears it's impossible to emulate a Win keystroke, thus preventing the use of Snip and Sketch via a VBA button, I tried to come up with another solution. Maybe could there be another solution (that doesn't require the use of APIs, which would be a no no on the intranet at my company).

PS : I tried to post a sample file, but I didn't seem to find a possibility ? ^^'

 

[sxhall]

Hi Eawyne,

If I'm reading this right you want an image of just the userform/popup?

Have you tried the below? Sends Alt and PrintScreen to only capture the active window.

Application.SendKeys "(%{1068})", True

 

[Eawyne]

Well, that makes it easy ! Splendid ^^ Thanks.

For the sake of answering my own question, I eventually came up with something ; makes the snap, pastes it, edits it and then cuts it :

Dim IsOn As Boolean

    Application.SendKeys "({1068})", True

    DoEvents
    ActiveSheet.Paste

    Dim shp As Shape
        With ActiveSheet
            Set shp = .Shapes(.Shapes.Count)
        End With

    Dim h As Single, w As Single
        h = -(600 - shp.Height)
        w = -(880 - shp.Width)

        shp.LockAspectRatio = False

        shp.PictureFormat.Crop.PictureWidth = 640
        shp.PictureFormat.Crop.PictureHeight = 480
        shp.PictureFormat.CropLeft = 540
        shp.PictureFormat.CropRight = 540
        shp.PictureFormat.CropTop = 380
        shp.PictureFormat.CropBottom = 310

        shp.Cut

    Unload Popup_specHSTOR

    Numlock_Toggle

The Numlock Toggle deals with the Numlock key toggling off and on when using the Keystroke, here's the code that deals with it :

Option Explicit
' Code found on :
' https://stackoverflow.com/questions/38018232/send-keys-is-disabling-numlock
'/!\ See the end of the segment to see what commands work in the modules /!\
 
' API declarations
#If VBA7 And Win64 Then
    Private Declare PtrSafe Sub keybd_event Lib "USER32" ( _
                                ByVal bVk As Byte, _
                                ByVal bScan As Byte, _
                                ByVal dwflags As Long, _
                                ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function GetKeyState Lib "USER32" (ByVal nVKey As Long) As Integer
#Else
    Private Declare Sub keybd_event Lib "USER32" ( _
                                ByVal bVk As Byte, _
                                ByVal bScan As Byte, _
                                ByVal dwflags As Long, _
                                ByVal dwExtraInfo As Long)
    Private Declare Function GetKeyState Lib "USER32" (ByVal nVKey As Long) As Integer
#End If
 
'Constant declarations
Private Const VK_NUMLOCK = &H90
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
 
'===================================================================
'PROPERTIES
'
 
'=========================================
'Returns the current Numlock state
Public Property Get Numlock() As Boolean
    Numlock = Numlock_State
End Property
 
'=========================================
'Sets the Numlock state
'   true = turn numlock on
'   false = turn numlock off
Public Property Let Numlock(State As Boolean)
    If State <> Numlock_State Then Numlock_Toggle
End Property
 
'===================================================================
'METHODS
'
 
'=========================================
'Returns the current Numlock state
Private Function Numlock_State() As Boolean
    DoEvents    'Required for key messages to be processed
    Numlock_State = CBool(GetKeyState(VK_NUMLOCK))
End Function
 
'=========================================
'Sets the Numlock state
'
'   State:  true = turn numlock on
'           false = turn numlock off
Private Sub Numlock_Set(State As Boolean)
    If State <> Numlock_State Then Numlock_Toggle
End Sub
 
'=========================================
'Toggles the Numlock state
Public Sub Numlock_Toggle()
    Dim previous_state As Boolean
    previous_state = Numlock_State
 
    keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY, 0  'Simulate Numlock key Press
    keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0        'Simulate Numlock key Release
 
End Sub

'=========================================
'Usage inside modules
'=========================================
'Public Sub Example()
'    'Turn Numlock on:
'    Numlock = True
'
'    'Turn Numlock off:
'    Numlock = False
'
'    'Check Numlock state:
'    Dim IsOn As Boolean
'    IsOn = Numlock
'
'    'Toggle Numlock state:
'    Numlock_Toggle
'End Sub