utiliataire de capture d'ecran avec selection dynamique de la partie d'ecran avec (userform)

Bonjour a tous
je vous propose un exemplaire simplifier de mon utilitaire de capture

le principe
j'ouvre un userform sur le quel j'ai enlevé la caption et rendu resizable avec la souris

il est rendu translucide pour voir ce qu'il y a en dessous

avec la souris rester appuyé et déplacer le userform a son grés
avec le clic droit capturer tout simplement
le double click le ferme pour annuler la capture
redimensionner en restant appuyé sur les bords comme les fenêtres classiques

cet userform peut très bien être logé dans un xla(m)

méthode d'appel

avec boite de dialogue pour choisir le chemin

Code:

1
2
3
Private Sub CommandButton1_Click()
With captur: .Show 0: .Tag = 1: End With
End Sub

enregistre directement sur le burau

Code:

1
2
3
Private Sub CommandButton2_Click()
captur.Show 0
End Sub

code dans l'userform

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Option Explicit
'application des modification
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'trouver le handle
Private Declare Function fwa Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'on redessine la barre sinon elle se retrouve en bas de l'userform
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
'capturer le handle et pouvoir le deplacer
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 Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
'api pour capture basic
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 IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim handle
Dim handleApp
Dim otherhandle
Dim LW
Dim plan
Private Sub UserForm_Activate()
    Me.BackColor = vbRed
    handle = fwa(vbNullString, Me.Caption)
    handleApp = Application.hwnd
    SetParent handle, GetDesktopWindow()
    SetWindowPos handleApp, 1, 0&, 0&, 0&, 0&, (&H10 Or &H40 Or &H1 Or &H2)     'force l'userform au  premier plan
    SetWindowLongA handle, -16, &H140F0101: DrawMenuBar handle    ' sans caption cadre epais coin  arrondi et elastique
    SetWindowLongA handle, -20, &H80109    'Rajoute l'attribut transparent à la fenêtre.
    SetLayeredWindowAttributes handle, 0, 60, &H2    'application de la transparence de 0 a 255 ici 60
    LW = Round(Me.Height - Me.InsideHeight)    'recupération de l epaisseur  du cadre
    SetWindowPos handle, -1, 0&, 0&, 0&, 0&, (&H1 Or &H2)    'force l'userform au  premier plan
End Sub
 
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Unload Me
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim hPicAvail, fname, chemin$
    If Button = 1 Then
        ReleaseCapture
        SendMessage handle, &HA1, 2, 0&
    Else
        With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With
    SetWindowLongA handle, -16, &H94080080: SetWindowLongA handle, -20, &H0: DrawMenuBar handle   ' sans caption
    SetWindowLongA handle, -20, &H80109
    SetLayeredWindowAttributes handle, 0, 0, &H2
    Me.Move Me.Left + (LW / 2), Me.Top + (LW / 2), Me.Width - (LW), Me.Height - (LW)
      SetWindowPos handle, -1, 0&, 0&, 0&, 0&, (&H1 Or &H2)    'force l'userform au  premier plan
    'SetParent handle, GetDesktopWindow()
     keybd_event &H2C, 1, 0, 0: keybd_event &H2C, 1, &H2, 0    'on appuie et  on relache la touche snapshot
    'on va boucler tant que le contenu du clipboard n'est pas BITMAP soit (2) le temps necessaire a ce que
    'la touche print excecute sa tache et envoie les informations au clipboard
    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(2): Loop While hPicAvail = 0    'Or (Timer - T) > 1000
    If Me.Tag <> "" Then
        fname = Application.GetSaveAsFilename(InitialFileName:=Environ("userprofile") & "\Desktop", filefilter:="image Files (*.jpg), *.jpg", Title:="ENREGISTREMENT DE LA CAPTURE")
        If fname <> False Then chemin = fname Else Exit Sub
    Else
        chemin = Environ("userprofile") & "\Desktop\capture.jpg"
    End If
    'crée un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, Me.Width, Me.Height)
        .Chart.Paste: .Chart.Export chemin, "jpg"    'colle l'image dans graphique puis exportation  le graphique en image jog
        .Delete
    End With
    'ActiveSheet.Paste
    Unload Me
    End If
End Sub
 
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If GetActiveWindow() <> handleApp Then otherhandle = GetActiveWindow()
End Sub

edit :

aurais-je oublié de préciser de nommer le userform "captur" ;)

Salut Patrick,
Sympa cet utilitaire.

Je préciserai juste pour la compréhension que CommandButton1_Click et CommandButton2_Click font références à des boutons SUR une feuille du classeur.

et que c'est la taille (ajustable) du formulaire qui détermine l'étendue de la capture.

En plus cela marche même sur des fenêtres en dehors de Excel. Bravo.

re

bonjour oliv
oui le but c'était ca pouvoir capturer n'importe quoi a l'écran (même ce qui n'est pas excel )

il me reste un seul soucis a régler sur ce projet
le fait que si on a deux fenêtre croisée dont l'une est Excel le fait d'activer le Userform réaffiche l'application au premier plan

j'ai tout essayé rien n'y fait

Citation:

Envoyé par patricktoulon

bonjour oliv
... si on a deux fenêtre croisée dont l'une est Excel le fait d'activer le Userform réaffiche l'application au premier plan
...

c'est quoi 2 fenêtres croisées ?

1 pièce(s) jointe(s)

RE

RE
deux fenêtre croisées c'est par exemple Excel affifhée (windowsate normal) avec une autre fenêtres la couvrant en partie

le fait de cliquer sur l'userform pour capturer remet Excel au premier plan et donc la partie cachée d'Excel par l'autre fenêtre est de nous apparente
ce qui a pour conséquence de capturer ce qu'il se trouve sous l'userform

gênant quand on veux capturer les deux partie de fenêtres

j'ai bien trouvé une solution mais elle ne me plais pas

a savoir le même principe que l'outils de capture de Windows 7

2 fenêtres (userform) l'un ayant la capture total de l'écran en plein écran et sans caption et l'autre faisant ce que celui actuel fait

PS:pour du HD(capture autre définition) j'ai une autre solution si ca t'intéresse je crois même l'avoir déjà partagé
c'est par ici
https://www.developpez.net/forums/d1...rint-snapshot/

si tu a une solution pour ce problème je suis preneur

je me demande si il y a une api pour capter leur index en terme de positon se serait le top mémoriser avant click et repositionner l'ors du click avant capture

démonstration du problème
Pièce jointe 327152

Salut,

il faudrait passer l'autre fenêtre en TOP_MOST , mais je pense que simplement en reproduisant le ALT+TAB tu auras tes fenêtres à leur position précédente

re

re
bonjour oliv
tu parle de simulation de key c'est ca ?

je vais regarder ca
merci

edit :
bon ben apres test c'est pire d'autant plus que la fenêtre capturée c'est celle qui s'affiche quand on tape ces deux touches et même en remettant l'usf au premier plan c'est cette fenêtre qui est capturée