Capture écran userform

**JGOPBD** · 11/08/2020, 14h20

Bonjour,

Je voudrais réaliser une capture d'écran de la userform et ensuite la coller dans une feuille du fichier Excel.

J'aimerais pouvoir ouvrir la userform puis la compléter et ensuite appuyer sur un bouton qui me permette de réaliser l'action ci-dessus.

Merci.

Invité · 11/08/2020, 15h59

Envoyé par JGOPBD

Bonjour,

Pour faire cela, j'utilise la touche "Imp écr" sur mon clavier.

**JGOPBD** · 11/08/2020, 16h02

Bonjour,

Merci pour votre retour.

Est-ce que vous auriez une façon de le faire avec une macro s'il vous plait ?

Merci.

**MarcelG** · 11/08/2020, 16h05

Bonjour,

Hé, salut Eric

Il existe aussi l'applicatif "Capture" intégré aux versions récentes de Windows (la bulle jaune avec les ciseaux).

Invité · 11/08/2020, 16h05

Envoyé par JGOPBD

Non, je ne connais pas. Je suppose que cela doit être possible en utilisant des commandes clavier.

Invité · 11/08/2020, 16h08

Envoyé par MarcelG

Bonjour Marcel,

Oui, je l'utilise tous les jours, mais des fois tu es obligé de faire des impressions écran lorsque tu veux montrer une liste dans une Combobox par exemple.

**JGOPBD** · 11/08/2020, 16h13

Bonjour,

Merci pour votre retour.

Est-ce que vous auriez une façon de le faire avec une macro afin que je puisse coller cette impression automatiquement dans le fichier Excel s'il vous plait ?

Merci.

**Ben_L** · 11/08/2020, 16h24

Bonjour,

Vous pourriez en effet simuler l'appui sur la touche "Imprime écran" à l'aide de SendKey :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Application.SendKeys "(%{1068})"
DoEvents

Mais cela ne permet pas d'obtenir l'image de la UserForm uniquement. Tout l'écran (voire les deux écrans, si vous en avez 2) sera copié.

Essayez plutôt le code suivant (il faut un bouton nommé CommandButton sur votre UserForm) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1
 
Private Sub CommandButton1_Click()
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
 
    DoEvents
 
    ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
End Sub

A adapter pour coller l'image là où vous le souhaitez.

Cdt

**laurent_ott** · 11/08/2020, 19h45

Bonjour.
Il est possible en VBA de faire une copie d'un formulaire en fichier image BMP.
Voir ce code qui ressemble à une usine à gaz mais qui fonctionne pourtant (à condition d'avoir une version Excel 32 Bits, pour les 64 Bits il faut adapter les API).
Pour plus d'informations et comprendre comment ça marche, voir le tome 2 dans ma signature ou ici http://laurent-ott.developpez.com/tu...el-vba-tome-2/.

Par exemple pour copier le formulaire UserForm1 dans un fichier nommé Test.BMP (dans le répertoire de l'application) l'appel est : CopieFormulaireEnBMP UserForm1, "Test.BMP"
Ce fichier image peut être joint dans une messagerie ou dans Excel.

Note : Suivant la version Excel utilisée, il est peut-être nécessaire de corriger les pixels qui définissent le cadre du formulaire pour éviter les débordements.

Bonne continuation.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
Option Explicit
 
Private Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "Gdi32" (ByVal hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw 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 GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 GetDIBits Lib "Gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitmapInfo, ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "Gdi32" (ByVal hdc As Long) As Long
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type BitmapInfo
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
Private Type BitMapFileHeader
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0&
Private Const SRCCOPY = &HCC0020
 
'------------------------------------------------------------------------------------------------
Private Function PointsEnPixelsX(lPoint As Long) As Long
'------------------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 88) ' LOGPIXELSX
PointsEnPixelsX = CLng(lPoint / Mult)
End Function
 
'------------------------------------------------------------------------------------------------
Private Function PointsEnPixelsY(lPoint As Long) As Long
'------------------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 90) ' LOGPIXELSY
PointsEnPixelsY = CLng(lPoint / Mult)
End Function
 
'------------------------------------------------------------------------------------------------
Public Sub CopieFormulaireEnBMP(ByVal ObjFormulaire As Object, ByVal StrNomDuFichier As String)
'------------------------------------------------------------------------------------------------
' Copie un formulaire en fichier BMP.
'------------------------------------------------------------------------------------------------
' ObjFormulaire : Nom du formulaire.
' StrNomDuFichier : Non du fichier généré et si l'extention .BMP n'est pas mise alors la rajoute.
' Exemple d'utilisation : CopieFormulaireEnBMP UserForm1, "Test.BMP"
'------------------------------------------------------------------------------------------------
Dim x1 As Long, Y1 As Long, x2 As Long, Y2 As Long
Dim Irect As RECT
Dim lngLargeur As Long, lngHauteur As Long
Dim lngHdc As Long
Dim lngHBmp As Long
Dim bmiBitmapInfo As BitmapInfo
Dim bmfBitmapFileHeader As BitMapFileHeader
Dim lngFnum As Integer
Dim pixels() As Byte
Dim bolOuvert As Boolean
Dim StrFichier As String
 
x1 = x1 + PointsEnPixelsX(ObjFormulaire.Left)
Y1 = Y1 + PointsEnPixelsY(ObjFormulaire.Top)
x2 = x1 + PointsEnPixelsX(ObjFormulaire.Width)
Y2 = Y1 + PointsEnPixelsY(ObjFormulaire.Height)
 
lngHauteur = Y2 - Y1
lngLargeur = x2 - x1
 
' Crée un bitmap vierge:
' ~~~~~~~~~~~~~~~~~~~~~~
With bmiBitmapInfo
  .biBitCount = 32
  .biCompression = BI_RGB
  .biPlanes = 1
  .biSize = Len(bmiBitmapInfo)
  .biHeight = lngHauteur
  .biWidth = lngLargeur
  .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
 
lngHdc = CreateCompatibleDC(0)
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
Call SelectObject(lngHdc, lngHBmp)
 
' Copie la partie de l'écran demandée:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Call BitBlt(lngHdc, 0, 0, lngLargeur, lngHauteur, GetDC(GetDesktopWindow()), x1, Y1, SRCCOPY)
 
' Crée l'entête du fichier bmp:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With bmfBitmapFileHeader
  .bfType = &H4D42&
  .bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
  .bfSize = .bfOffBits + bmiBitmapInfo.biSizeImage
End With
 
' Lit les bits du bitmap et les place dans le tableau de pixels:
ReDim pixels(1 To 4, 1 To lngLargeur, 1 To lngHauteur)
Call GetDIBits(lngHdc, lngHBmp, 0, lngHauteur, pixels(1, 1, 1), bmiBitmapInfo, DIB_RGB_COLORS)
 
' Demande un numéro temporaire de fichier:
lngFnum = FreeFile
 
' Supprime le fichier s'il existe:
StrFichier = StrNomDuFichier
If StrFichier = "" Then StrFichier = "CopieEnBMP" ' nom du fichier par défaut si non renseigné
If InStr(1, StrFichier, ".") = 0 Then StrFichier = StrFichier & ".BMP" ' ajoute l'extension .BMP si besoin
If InStr(1, StrFichier, ":") = 0 Then StrFichier = ThisWorkbook.Path & "\" & StrFichier ' répertoire du projet si chemin non renseigné.
On Error Resume Next
Kill StrFichier
 
' Crée le fichier:
Open StrFichier For Binary As lngFnum
bolOuvert = True
 
' Ecrit l'entête:
Put #lngFnum, , bmfBitmapFileHeader
 
' Ecrit les informations du bitmap:
Put #lngFnum, , bmiBitmapInfo
 
' Ecrit les bits de l'image:
Put #lngFnum, , pixels
 
' Ferme le fichier si ouvert:
If bolOuvert Then Close lngFnum
 
' Supprime les objets:
If lngHBmp <> 0 Then DeleteObject lngHBmp
If lngHdc <> 0 Then DeleteDC lngHdc
 
End Sub
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------

**JGOPBD** · 12/08/2020, 11h57

Bonjour,

Merci pour vos retour.

Excusez-moi mais je suis débutant et je n'arrive pas à mettre en place cette macro, est-ce que vous auriez un fichier support avec lequel je pourrais comprendre comment celle-ci fonctionne s'il vous plait ?

Merci.

**laurent_ott** · 12/08/2020, 12h20

Il suffit de copier coller ce code dans un nouveau module ordinaire, et d'associer le bouton du formulaire à la fonction mise dans l'exemple.
Pour compléter tes connaissances tu peux lire le tome 1, voir dans ma signature.
Cordialement.

**ARTURO83** · 12/08/2020, 12h57

Bonjour,

Vous pouvez aussi faire ceci, modifiez les propriétés de l'userForm dans la catégorie "Comportement, à "ShowModal" mettre à "False". A partir de là, vous pouvez utiliser l'outil de capture d'écran et coller l'image où vous voulez.
Pièce jointe 577128

Cdlt

**JGOPBD** · 12/08/2020, 13h20

Bonjour,

Merci pour vos retours.

J'ai créé un bouton et je voulais savoir par quoi je dois remplacer "Creat_arbo" afin que la macro fonctionne ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Private Sub CommandButton2_Click()
 
    Call Creat_arbo
 
End Sub

Merci.

**jurassic pork** · 12/08/2020, 16h40

hello,
voici un code qui réalise la capture d'un userform affiché. C'est le principe du code à Ben_L, mais il y a des tempos pour que cela fonctionne avec un formulaire qu'on affiche :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal _
    bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Const VK_KEYUP = &H2
Const VK_SNAPSHOT = &H2C
Const VK_MENU = &H12
 
 
'=====================================================================
'- SUBROUTINE : PRINT SCREEN & PASTE INTO THE WORKSHEET
'- events and SendKeys work slowly, so need lots of delays in the code
'- ALT+PrtScrn copies active window
'- PrtScrn copies the entire desktop
'=====================================================================
Private Sub CopyUserFormToWorksheet()
    Application.Wait Now + TimeValue("00:00:02")
    '- API print screen
    keybd_event VK_MENU, 0, 0, 0        ' Alt key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, 0, 0    ' PrintScreen key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0
    DoEvents
    keybd_event VK_MENU, 0, VK_KEYUP, 0
    DoEvents
    Application.Wait Now + TimeValue("00:00:02")
    '---------------------------------------------------------------
    '- paste picture to worksheet
    Sheets("Feuille1").Paste Range("A10")
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' WAIT 1 SECOND
End Sub
'=====================================================================
 
 
Sub ShowUserForm()
UserForm1.Show (False)
CopyUserFormToWorksheet
End Sub

La macro ShowUserForm affiche le formulaire en mode non modal puis on copie le formulaire et on le colle dans la cellule A10 de la feuille 1.

Ami calmant, J.P

**JGOPBD** · 13/08/2020, 17h18

Bonjour,

Merci pour votre retour.

Je ne comprend pas le fonctionnement est-ce qu'il faut un bouton pour activer la copie ?

Merci.

Invité · 13/08/2020, 17h32

Envoyé par JGOPBD

Bonjour,

J'ai utilisé la solution de Jurassic Pork (désolé pour les autres contributeurs, je n'ai pas tout essayé...)
J'ai modifié la solution pour faire la copie depuis un bouton dans le userform.

**laurent_ott** · 13/08/2020, 18h58

Bonjour.
Effectivement, je ne connaissais pas la subtilité de ALT+PrtScrn qui ne copie que la fenêtre active contrairement à PrtScrn qui copie tout l'écran.

J'ai retiré les phases d'attente et sur mon poste (Excel 2016) ça marche bien.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub CopyUserFormToWorksheet()
    '- API print screen
    keybd_event VK_MENU, 0, 0, 0        ' Alt key down
    keybd_event VK_SNAPSHOT, 0, 0, 0    ' PrintScreen key down
    keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0
    keybd_event VK_MENU, 0, VK_KEYUP, 0
    '---------------------------------------------------------------
    '- paste picture to worksheet
    Sheets("Feuil1").Paste Range("A10")
    DoEvents
 End Sub

Cordialement.

**JGOPBD** · 14/08/2020, 09h10

Bonjour,

Merci pour vos retours.

J'ai un soucis avec cette ligne représenté par situé à droite (problème sur cette ligne de code) auriez-vous une idée du problème.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
' https://www.developpez.net/forums/d2088646/logiciels/microsoft-office/excel/macros-vba-excel/capture-ecran-userform/#post11605894
 
 
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal _
    bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Const VK_KEYUP = &H2
Const VK_SNAPSHOT = &H2C
Const VK_MENU = &H12
 
 
'=====================================================================
'- SUBROUTINE : PRINT SCREEN & PASTE INTO THE WORKSHEET
'- events and SendKeys work slowly, so need lots of delays in the code
'- ALT+PrtScrn copies active window
'- PrtScrn copies the entire desktop
'=====================================================================
Sub CopyUserFormToWorksheet()
    Application.Wait Now + TimeValue("00:00:02")
    '- API print screen
    keybd_event VK_MENU, 0, 0, 0        ' Alt key down (problème sur cette ligne de code)
    DoEvents
    keybd_event VK_SNAPSHOT, 0, 0, 0    ' PrintScreen key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0
    DoEvents
    keybd_event VK_MENU, 0, VK_KEYUP, 0
    DoEvents
    Application.Wait Now + TimeValue("00:00:02")
    '---------------------------------------------------------------
    '- paste picture to worksheet
    Sheets("Feuil2").Paste Range("A10")
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' WAIT 1 SECOND
End Sub
'=====================================================================
 
 
Sub ShowUserForm()
UserForm1.Show (False)
'CopyUserFormToWorksheet
End Sub

Merci.

**Ben_L** · 14/08/2020, 12h43

Tu utilises VK_MENU (qui vaut 18, soit 12 en héxa) en lieu et place de VK_LMENU (qui vaut 164, soit A4 en héxa).
Regardes mon précédent post pour la syntaxe en VBA.
Les noms des constantes n'ont aucune importance (si ce n'est de faciliter la lecture du code), ce sont leurs valeurs qui doivent être correctement renseignées.

En outre, l'utilisation de la fonction Wait rend ton code dépendant de valeurs de temps rentrées en dur, ce qui est plutôt déconseillé et ne sert à rien ici.

Cdt