capture d'écran d'un userform

Version imprimable

bonjour
j'essaye depuis plusieurs jours de réaliser une capture d'écran d'un userform et de le sauvegarder au format jpg dans mon disque dur, c'est pour pouvoir envoyer la capture écran via outlook

j'ai essayé ce code, mais malheureusement, l'image qu'il me sauvegarde est "vide", elle est toute blanche
par contre si je suis en mode pas à pas, ça fonctionne!!
si je mets des tempos de 5 secondes entre chaque ligne de code, ça ne fonctionne pas (image blanche)

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
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 SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function fwa Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const VK_SNAPSHOT = &H2C
Private Sub CommandButton1_Click()
    Dim hPicAvail As Long, T,Handle,chemin
    Handle = fwa(vbNullString, Me.Caption)
    chemin = Environ("userprofile") & "\Desktop\" & Me.Name & ".jpg"
    SetWindowLongA Handle, -16, &H94080080: SetWindowLongA Handle, -20, &H0: DrawMenuBar Handle   ' on enleve la  caption(l'encadrement)on garde que l'interieur
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With    'methode 1
    keybd_event VK_SNAPSHOT, 1, 0, 0: keybd_event VK_SNAPSHOT, 1, &H2, 0    'on appuie et  on relache la touche snapshot
 
    'on va boucler dans que le contenu du clipboard n'est pas BITMAP soit (2)
    Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(2): Loop While hPicAvail = 0    'Or (Timer - T) > 1000
 
    '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    'supprime le chart
    End With
    SetWindowLongA Handle, -16, &H94C80080: DrawMenuBar Handle      'on remet la caption au userform
    MsgBox "capture effectuée" & vbCrLf & chemin
End Sub

vous auriez une solution?

03/07/2020, 05h13
ARTURO83

Bonjour,

Autre solution simple et sans macro, modifiez les propriétés de l'userform.
Dans les propriétés du UserForm, dans la catégorie "Comportement", mettre "ShowModal =false", vous pourrez ainsi utiliser la capture d'écran sans problème.
Pièce jointe 574280

Cdlt
03/07/2020, 06h58
monfiston

Je pense que l on ne c est pas compris, quand mon userform est affiché, je souhaite que si l utilisateur clique sur un bouton, ça prend une capture d écran et ça génère un mail avec la capture d écran dans ce mail

Bonjour,

Cette solution de kiki29 va enregistrer ton Userform en pdf.
https://www.developpez.net/forums/d4...e/#post7742208

Ne te restera plus qu'à joindre le fichier pdf à ton mail...

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
Option Explicit
 
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()
Dim sNomPDF As String
 
    Application.ScreenUpdating = False
 
    PrintScreen
    DoEvents
 
    ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
 
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.197)
        .RightMargin = Application.InchesToPoints(0.197)
        .TopMargin = Application.InchesToPoints(0.197)
        .BottomMargin = Application.InchesToPoints(0.197)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
    End With
 
    ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
    sNomPDF = ActiveWorkbook.Path & "\" & "UserForm.pdf"
 
    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPDF, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=False, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
 
    Application.DisplayAlerts = False
    Worksheets(Worksheets.Count).Delete
    Unload Me
    Application.DisplayAlerts = True
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub PrintScreen()
    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
End Sub

03/07/2020, 09h03
monfiston

Merci, Mais, il faut que ce soit une image jpg, pour que je puisse mettre la mettre dans le message du mail

Bon...

Si tu disposes de PowerPoint sur ton pc, voici une solution adaptée de : http://vbanet.blogspot.com/2009/06/u...f-gif-jpg.html

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
Option Explicit
 
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Const strEXT As String = "JPG"
 
Private Sub CommandButton1_Click()
    keybd_event &H12, MapVirtualKey(&H12, 0), 0, 0
    keybd_event &H2C, 0, 0, 0
    DoEvents
    keybd_event &H12, MapVirtualKey(&H12, 0), 2, 0
    Call UF_PP
End Sub
 
Private Sub UF_PP()
Dim objPPRange As Object, objPPApp As Object, objSlide As Object
Dim strTMP As String, strEX As String
    On Error GoTo Fin
    Application.ScreenUpdating = False
    strTMP = Me.Caption
    Set objPPApp = CreateObject("PowerPoint.Application")
    With objPPApp
        .Presentations.Add
        .ActivePresentation.Slides.Add 1, 12
        Set objSlide = .ActivePresentation.Slides(1)
        Set objPPRange = objSlide.Shapes.Paste
        With objPPRange
            .LockAspectRatio = False
            .Width = objSlide.Design.SlideMaster.Width
            .Height = objSlide.Design.SlideMaster.Height
            .Align 4, True
            .Align 1, True
        End With
        objSlide.Export "C:\Users\" & Environ("username") & "\Desktop\" & strTMP & "." & strEXT, strEXT
        .Quit
    End With
Fin:
    Application.ScreenUpdating = True
    Set objPPRange = Nothing
    Set objSlide = Nothing
    Set objPPApp = Nothing
End Sub

03/07/2020, 10h08
monfiston

Merci, ca fonctionne, mais j aurais plutôt souhaité ne pas utiliser une autre application
03/07/2020, 10h55
pijaku

Ton Userform est-il "plein écran"?
03/07/2020, 11h09
monfiston

Oui

En fait, peu importe...

Essaye ceci :

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
Option Explicit
 
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Private Const VK_BAS = 40
 
Private Sub CommandButton1_Click()
    keybd_event VK_MENU, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
    DoEvents
    EnvoiMail
End Sub
 
Sub EnvoiMail()
Dim OutApp As Outlook.Application, OutMail As Outlook.MailItem, olInsp As Object, wdDoc As Object, oRng As Object, msg As String, i As Integer
 
    msg = "Bonjour," & vbCrLf & vbCrLf & _
                "Vous trouverez, ci-dessous, une copie de l'userform" & vbCrLf & vbCrLf
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = "jack.bauer@24h.fr"
        .cc = vbNullString
        .Subject = "Userform"
        .Body = msg
        .Display
        For i = 0 To UBound(Split(msg, vbCrLf))
            keybd_event VK_BAS, 0, 0, 0
            keybd_event VK_BAS, 0, KEYEVENTF_KEYUP, 0
        Next
        SendKeys "^v", True
    End With
End Sub

11/11/2020, 10h57
gahakkens

Avez-vous trouve la solution

Probleme microsoft apparemment connu

Si on utilise la methode chart => rajouter la ligne
.ChartArea.Parent.Select 'new for Excel 2016
si on utilise la methode objet => rajouter la ligne
Ch.Chart.Parent.Select.

https://stackoverflow.com/questions/...-in-excel-2016

Chez moi cela fonctionne desormais.